1196 lines · cpp
1//===-- lib/runtime/edit-input.cpp ------------------------------*- C++ -*-===//2//3// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.4// See https://llvm.org/LICENSE.txt for license information.5// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception6//7//===----------------------------------------------------------------------===//8 9#include "edit-input.h"10#include "flang-rt/runtime/namelist.h"11#include "flang-rt/runtime/utf.h"12#include "flang/Common/optional.h"13#include "flang/Common/real.h"14#include "flang/Common/uint128.h"15#include "flang/Runtime/freestanding-tools.h"16#include <algorithm>17#include <cfenv>18 19namespace Fortran::runtime::io {20RT_OFFLOAD_API_GROUP_BEGIN21 22static inline RT_API_ATTRS bool IsCharValueSeparator(23 const DataEdit &edit, char32_t ch) {24 return ch == ' ' || ch == '\t' || ch == '/' ||25 ch == edit.modes.GetSeparatorChar() ||26 (edit.IsNamelist() && (ch == '&' || ch == '$'));27}28 29// Checks that a list-directed input value has been entirely consumed and30// doesn't contain unparsed characters before the next value separator.31static RT_API_ATTRS bool CheckCompleteListDirectedField(32 IoStatementState &io, const DataEdit &edit) {33 if (edit.IsListDirected()) {34 std::size_t byteCount;35 if (auto ch{io.GetCurrentChar(byteCount)}) {36 if (!IsCharValueSeparator(edit, *ch)) {37 const auto &connection{io.GetConnectionState()};38 io.GetIoErrorHandler().SignalError(IostatBadListDirectedInputSeparator,39 "invalid character (0x%x) after list-directed input value, "40 "at column %d in record %d",41 static_cast<unsigned>(*ch),42 static_cast<int>(connection.positionInRecord + 1),43 static_cast<int>(connection.currentRecordNumber));44 return false;45 }46 }47 }48 return true;49}50 51template <int LOG2_BASE>52static RT_API_ATTRS bool EditBOZInput(53 IoStatementState &io, const DataEdit &edit, void *n, std::size_t bytes) {54 // Skip leading white space & zeroes55 common::optional<int> remaining{io.CueUpInput(edit)};56 const ConnectionState &connection{io.GetConnectionState()};57 auto leftTabLimit{connection.leftTabLimit.value_or(0)};58 auto start{connection.positionInRecord - leftTabLimit};59 common::optional<char32_t> next{io.NextInField(remaining, edit)};60 if (next.value_or('?') == '0') {61 do {62 start = connection.positionInRecord - leftTabLimit;63 next = io.NextInField(remaining, edit);64 } while (next && *next == '0');65 }66 // Count significant digits after any leading white space & zeroes67 int digits{0};68 int significantBits{0};69 char32_t comma{edit.modes.GetSeparatorChar()};70 for (; next; next = io.NextInField(remaining, edit)) {71 char32_t ch{*next};72 if (ch == ' ' || ch == '\t') {73 if (edit.modes.editingFlags & blankZero) {74 ch = '0'; // BZ mode - treat blank as if it were zero75 } else {76 continue;77 }78 }79 if (ch >= '0' && ch <= '1') {80 } else if (LOG2_BASE >= 3 && ch >= '2' && ch <= '7') {81 } else if (LOG2_BASE >= 4 && ch >= '8' && ch <= '9') {82 } else if (LOG2_BASE >= 4 && ch >= 'A' && ch <= 'F') {83 } else if (LOG2_BASE >= 4 && ch >= 'a' && ch <= 'f') {84 } else if (ch == comma) {85 break; // end non-list-directed field early86 } else {87 io.GetIoErrorHandler().SignalError(88 "Bad character '%lc' in B/O/Z input field", ch);89 return false;90 }91 if (digits++ == 0) {92 if (ch >= '0' && ch <= '1') {93 significantBits = 1;94 } else if (ch >= '2' && ch <= '3') {95 significantBits = 2;96 } else if (ch >= '4' && ch <= '7') {97 significantBits = 3;98 } else {99 significantBits = 4;100 }101 } else {102 significantBits += LOG2_BASE;103 }104 }105 auto significantBytes{static_cast<std::size_t>(significantBits + 7) / 8};106 if (significantBytes > bytes) {107 io.GetIoErrorHandler().SignalError(IostatBOZInputOverflow,108 "B/O/Z input of %d digits overflows %zd-byte variable", digits, bytes);109 return false;110 }111 // Reset to start of significant digits112 io.HandleAbsolutePosition(start);113 remaining.reset();114 // Make a second pass now that the digit count is known115 runtime::memset(n, 0, bytes);116 int increment{isHostLittleEndian ? -1 : 1};117 auto *data{reinterpret_cast<unsigned char *>(n) +118 (isHostLittleEndian ? significantBytes - 1 : bytes - significantBytes)};119 int bitsAfterFirstDigit{(digits - 1) * LOG2_BASE};120 int shift{bitsAfterFirstDigit & 7};121 if (shift + (significantBits - bitsAfterFirstDigit) > 8) {122 shift = shift - 8; // misaligned octal123 }124 while (digits > 0) {125 char32_t ch{io.NextInField(remaining, edit).value_or(' ')};126 int digit{0};127 if (ch == ' ' || ch == '\t') {128 if (edit.modes.editingFlags & blankZero) {129 ch = '0'; // BZ mode - treat blank as if it were zero130 } else {131 continue;132 }133 }134 --digits;135 if (ch >= '0' && ch <= '9') {136 digit = ch - '0';137 } else if (ch >= 'A' && ch <= 'F') {138 digit = ch + 10 - 'A';139 } else if (ch >= 'a' && ch <= 'f') {140 digit = ch + 10 - 'a';141 } else {142 continue;143 }144 if (shift < 0) {145 if (shift + LOG2_BASE > 0) { // misaligned octal146 *data |= digit >> -shift;147 }148 shift += 8;149 data += increment;150 }151 *data |= digit << shift;152 shift -= LOG2_BASE;153 }154 return CheckCompleteListDirectedField(io, edit);155}156 157// Prepares input from a field, and returns the sign, if any, else '\0'.158static RT_API_ATTRS char ScanNumericPrefix(IoStatementState &io,159 const DataEdit &edit, common::optional<char32_t> &next,160 common::optional<int> &remaining,161 IoStatementState::FastAsciiField *fastField = nullptr) {162 remaining = io.CueUpInput(edit, fastField);163 next = io.NextInField(remaining, edit, fastField);164 char sign{'\0'};165 if (next) {166 if (*next == '-' || *next == '+') {167 sign = *next;168 if (!edit.IsListDirected()) {169 io.SkipSpaces(remaining, fastField);170 }171 next = io.NextInField(remaining, edit, fastField);172 }173 }174 return sign;175}176 177RT_API_ATTRS bool EditIntegerInput(IoStatementState &io, const DataEdit &edit,178 void *n, int kind, bool isSigned) {179 auto &handler{io.GetIoErrorHandler()};180 RUNTIME_CHECK(handler, kind >= 1 && !(kind & (kind - 1)));181 if (!n) {182 handler.Crash("Null address for integer input item");183 }184 switch (edit.descriptor) {185 case DataEdit::ListDirected:186 if (IsNamelistNameOrSlash(io)) {187 return false;188 }189 break;190 case 'G':191 case 'I':192 break;193 case 'B':194 return EditBOZInput<1>(io, edit, n, kind);195 case 'O':196 return EditBOZInput<3>(io, edit, n, kind);197 case 'Z':198 return EditBOZInput<4>(io, edit, n, kind);199 case 'A': // legacy extension200 return EditCharacterInput(io, edit, reinterpret_cast<char *>(n), kind);201 default:202 handler.SignalError(IostatErrorInFormat,203 "Data edit descriptor '%c' may not be used with an INTEGER data item",204 edit.descriptor);205 return false;206 }207 common::optional<int> remaining;208 common::optional<char32_t> next;209 auto fastField{io.GetUpcomingFastAsciiField()};210 char sign{ScanNumericPrefix(io, edit, next, remaining, &fastField)};211 if (sign == '-' && !isSigned) {212 handler.SignalError("Negative sign in UNSIGNED input field");213 return false;214 }215 common::uint128_t value{0};216 bool any{!!sign};217 bool overflow{false};218 char32_t comma{edit.modes.GetSeparatorChar()};219 static constexpr auto maxu128{~common::uint128_t{0}};220 for (; next; next = io.NextInField(remaining, edit, &fastField)) {221 char32_t ch{*next};222 if (ch == ' ' || ch == '\t') {223 if (edit.modes.editingFlags & blankZero) {224 ch = '0'; // BZ mode - treat blank as if it were zero225 } else {226 continue;227 }228 }229 int digit{0};230 if (ch >= '0' && ch <= '9') {231 digit = ch - '0';232 } else if (ch == comma) {233 break; // end non-list-directed field early234 } else {235 if (edit.modes.inNamelist && ch == edit.modes.GetRadixPointChar()) {236 // Ignore any fractional part that might appear in NAMELIST integer237 // input, like a few other Fortran compilers do.238 // TODO: also process exponents? Some compilers do, but they obviously239 // can't just be ignored.240 while ((next = io.NextInField(remaining, edit, &fastField))) {241 if (*next < '0' || *next > '9') {242 break;243 }244 }245 if (!next || *next == comma) {246 break;247 }248 }249 handler.SignalError("Bad character '%lc' in INTEGER input field", ch);250 return false;251 }252 static constexpr auto maxu128OverTen{maxu128 / 10};253 static constexpr int maxLastDigit{254 static_cast<int>(maxu128 - (maxu128OverTen * 10))};255 overflow |= value >= maxu128OverTen &&256 (value > maxu128OverTen || digit > maxLastDigit);257 value *= 10;258 value += digit;259 any = true;260 }261 if (!any && !remaining) {262 handler.SignalError(263 "Integer value absent from NAMELIST or list-directed input");264 return false;265 }266 if (isSigned) {267 auto maxForKind{common::uint128_t{1} << ((8 * kind) - 1)};268 overflow |= value >= maxForKind && (value > maxForKind || sign != '-');269 } else {270 auto maxForKind{maxu128 >> (((16 - kind) * 8) + (isSigned ? 1 : 0))};271 overflow |= value >= maxForKind;272 }273 if (overflow) {274 handler.SignalError(IostatIntegerInputOverflow,275 "Decimal input overflows INTEGER(%d) variable", kind);276 return false;277 }278 if (sign == '-') {279 value = -value;280 }281 if (any || !handler.InError()) {282 // The value is stored in the lower order bits on big endian platform.283 // For memcpy, shift the value to the highest order bits.284#if USING_NATIVE_INT128_T285 auto shft{static_cast<int>(sizeof value - kind)};286 if (!isHostLittleEndian && shft >= 0) {287 auto shifted{value << (8 * shft)};288 runtime::memcpy(n, &shifted, kind);289 } else {290 runtime::memcpy(n, &value, kind); // a blank field means zero291 }292#else293 auto shft{static_cast<int>(sizeof(value.low())) - kind};294 // For kind==8 (i.e. shft==0), the value is stored in low_ in big endian.295 if (!isHostLittleEndian && shft >= 0) {296 auto l{value.low() << (8 * shft)};297 runtime::memcpy(n, &l, kind);298 } else {299 runtime::memcpy(n, &value, kind); // a blank field means zero300 }301#endif302 io.GotChar(fastField.got());303 return true;304 } else {305 return false;306 }307}308 309// Parses a REAL input number from the input source as a normalized310// fraction into a supplied buffer -- there's an optional '-', a311// decimal point when the input is not hexadecimal, and at least one312// digit. Replaces blanks with zeroes where appropriate.313struct ScannedRealInput {314 // Number of characters that (should) have been written to the315 // buffer -- this can be larger than the buffer size, which316 // indicates buffer overflow. Zero indicates an error.317 int got{0};318 int exponent{0}; // adjusted as necessary; binary if isHexadecimal319 bool isHexadecimal{false}; // 0X...320};321static RT_API_ATTRS ScannedRealInput ScanRealInput(322 char *buffer, int bufferSize, IoStatementState &io, const DataEdit &edit) {323 common::optional<int> remaining;324 common::optional<char32_t> next;325 int got{0};326 common::optional<int> radixPointOffset;327 // The following lambda definition violates the conding style,328 // but cuda-11.8 nvcc hits an internal error with the brace initialization.329 auto Put = [&](char ch) -> void {330 if (got < bufferSize) {331 buffer[got] = ch;332 }333 ++got;334 };335 char sign{ScanNumericPrefix(io, edit, next, remaining)};336 if (sign == '-') {337 Put('-');338 }339 bool bzMode{(edit.modes.editingFlags & blankZero) != 0};340 int exponent{0};341 char32_t comma{edit.modes.GetSeparatorChar()};342 if (!next || (!bzMode && *next == ' ') || *next == comma) {343 if (!edit.IsListDirected() && !io.GetConnectionState().IsAtEOF()) {344 // An empty/blank field means zero when not list-directed.345 // A fixed-width field containing only a sign is also zero;346 // this behavior isn't standard-conforming in F'2023 but it is347 // required to pass FCVS.348 Put('0');349 }350 return {got, exponent, false};351 }352 char32_t radixPointChar{edit.modes.GetRadixPointChar()};353 char32_t first{*next >= 'a' && *next <= 'z' ? *next + 'A' - 'a' : *next};354 bool isHexadecimal{false};355 if (first == 'N' || first == 'I') {356 // NaN or infinity - convert to upper case357 // Subtle: a blank field of digits could be followed by 'E' or 'D',358 for (; next &&359 ((*next >= 'a' && *next <= 'z') || (*next >= 'A' && *next <= 'Z'));360 next = io.NextInField(remaining, edit)) {361 if (*next >= 'a' && *next <= 'z') {362 Put(*next - 'a' + 'A');363 } else {364 Put(*next);365 }366 }367 if (first == 'N' && (!next || *next == '(') &&368 remaining.value_or(1) > 0) { // NaN(...)?369 std::size_t byteCount{0};370 if (!next) { // NextInField won't return '(' for list-directed371 next = io.GetCurrentChar(byteCount);372 }373 if (next && *next == '(') {374 int depth{1};375 while (true) {376 if (*next >= 'a' && *next <= 'z') {377 *next = *next - 'a' + 'A';378 }379 Put(*next);380 io.HandleRelativePosition(byteCount);381 io.GotChar(byteCount);382 if (remaining) {383 *remaining -= byteCount;384 }385 if (depth == 0) {386 break; // done387 }388 next = io.GetCurrentChar(byteCount);389 if (!next || remaining.value_or(1) < 1) {390 return {}; // error391 } else if (*next == '(') {392 ++depth;393 } else if (*next == ')') {394 --depth;395 }396 }397 next = io.NextInField(remaining, edit);398 }399 }400 } else if (first == radixPointChar || (first >= '0' && first <= '9') ||401 (bzMode && (first == ' ' || first == '\t')) ||402 (remaining.has_value() &&403 (first == 'D' || first == 'E' || first == 'Q'))) {404 if (first == '0') {405 next = io.NextInField(remaining, edit);406 if (next && (*next == 'x' || *next == 'X')) { // 0X...407 isHexadecimal = true;408 next = io.NextInField(remaining, edit);409 } else {410 Put('0');411 }412 }413 // input field is normalized to a fraction414 if (!isHexadecimal) {415 Put('.');416 }417 auto start{got};418 for (; next; next = io.NextInField(remaining, edit)) {419 char32_t ch{*next};420 if (ch == ' ' || ch == '\t') {421 if (isHexadecimal) {422 return {}; // error423 } else if (bzMode) {424 ch = '0'; // BZ mode - treat blank as if it were zero425 } else {426 continue; // ignore blank in fixed field427 }428 }429 if (ch == '0' && got == start && !radixPointOffset) {430 // omit leading zeroes before the radix point431 } else if (ch >= '0' && ch <= '9') {432 Put(ch);433 } else if (ch == radixPointChar && !radixPointOffset) {434 // The radix point character is *not* copied to the buffer.435 radixPointOffset = got - start; // # of digits before the radix point436 } else if (isHexadecimal && ch >= 'A' && ch <= 'F') {437 Put(ch);438 } else if (isHexadecimal && ch >= 'a' && ch <= 'f') {439 Put(ch - 'a' + 'A'); // normalize to capitals440 } else {441 break;442 }443 }444 if (got == start) {445 // Nothing but zeroes and maybe a radix point. F'2018 requires446 // at least one digit, but F'77 did not, and a bare "." shows up in447 // the FCVS suite.448 Put('0'); // emit at least one digit449 }450 // In list-directed input, a bad exponent is not consumed.451 auto nextBeforeExponent{next};452 const ConnectionState &connection{io.GetConnectionState()};453 auto leftTabLimit{connection.leftTabLimit.value_or(0)};454 auto startExponent{connection.positionInRecord - leftTabLimit};455 bool hasGoodExponent{false};456 if (next) {457 if (isHexadecimal) {458 if (*next == 'p' || *next == 'P') {459 next = io.NextInField(remaining, edit);460 } else {461 // The binary exponent is not optional in the standard.462 return {}; // error463 }464 } else if (*next == 'e' || *next == 'E' || *next == 'd' || *next == 'D' ||465 *next == 'q' || *next == 'Q') {466 // Optional exponent letter. Blanks are allowed between the467 // optional exponent letter and the exponent value.468 io.SkipSpaces(remaining);469 next = io.NextInField(remaining, edit);470 if (!next) {471 if (remaining.has_value()) {472 // bare exponent letter accepted in fixed-width field473 hasGoodExponent = true;474 } else {475 return {}; // error476 }477 }478 }479 }480 if (next &&481 (*next == '-' || *next == '+' || (*next >= '0' && *next <= '9') ||482 *next == ' ' || *next == '\t')) {483 bool negExpo{*next == '-'};484 if (negExpo || *next == '+') {485 next = io.NextInField(remaining, edit);486 }487 for (; next; next = io.NextInField(remaining, edit)) {488 if (*next >= '0' && *next <= '9') {489 hasGoodExponent = true;490 if (exponent < 10000) {491 exponent = 10 * exponent + *next - '0';492 }493 } else if (*next == ' ' || *next == '\t') {494 if (isHexadecimal) {495 break;496 } else if (bzMode) {497 hasGoodExponent = true;498 exponent = 10 * exponent;499 }500 } else {501 break;502 }503 }504 if (negExpo) {505 exponent = -exponent;506 }507 }508 if (!hasGoodExponent) {509 if (isHexadecimal) {510 return {}; // error511 }512 // There isn't a good exponent; do not consume it.513 next = nextBeforeExponent;514 io.HandleAbsolutePosition(startExponent);515 // The default exponent is -kP, but the scale factor doesn't affect516 // an explicit exponent.517 exponent = -edit.modes.scale;518 }519 // Adjust exponent by number of digits before the radix point.520 if (isHexadecimal) {521 // Exponents for hexadecimal input are binary.522 exponent += radixPointOffset.value_or(got - start) * 4;523 } else if (radixPointOffset) {524 exponent += *radixPointOffset;525 } else {526 // When no radix point (or comma) appears in the value, the 'd'527 // part of the edit descriptor must be interpreted as the number of528 // digits in the value to be interpreted as being to the *right* of529 // the assumed radix point (13.7.2.3.2)530 exponent += got - start - edit.digits.value_or(0);531 }532 }533 // Consume the trailing ')' of a list-directed or NAMELIST complex534 // input value.535 if (edit.descriptor == DataEdit::ListDirectedImaginaryPart) {536 if (!next || *next == ' ' || *next == '\t') {537 io.SkipSpaces(remaining);538 next = io.NextInField(remaining, edit);539 }540 if (!next || *next == ')') { // NextInField fails on separators like ')'541 std::size_t byteCount{1};542 if (!next) {543 next = io.GetCurrentChar(byteCount);544 }545 if (next && *next == ')') {546 io.HandleRelativePosition(byteCount);547 }548 }549 } else if (remaining) {550 while (next && (*next == ' ' || *next == '\t')) {551 next = io.NextInField(remaining, edit);552 }553 if (next && *next != comma) {554 return {}; // error: unused nonblank character in fixed-width field555 }556 }557 return {got, exponent, isHexadecimal};558}559 560static RT_API_ATTRS void RaiseFPExceptions(561 decimal::ConversionResultFlags flags) {562#undef RAISE563#if defined(RT_DEVICE_COMPILATION)564 Terminator terminator(__FILE__, __LINE__);565#define RAISE(e) \566 terminator.Crash( \567 "not implemented yet: raising FP exception in device code: %s", #e);568#else // !defined(RT_DEVICE_COMPILATION)569#ifdef feraisexcept // a macro in some environments; omit std::570#define RAISE feraiseexcept571#else572#define RAISE std::feraiseexcept573#endif574#endif // !defined(RT_DEVICE_COMPILATION)575 576// Some environment (e.g. emscripten, musl) don't define FE_OVERFLOW as allowed577// by c99 (but not c++11) :-/578#if defined(FE_OVERFLOW) || defined(RT_DEVICE_COMPILATION)579 if (flags & decimal::ConversionResultFlags::Overflow) {580 RAISE(FE_OVERFLOW);581 }582#endif583#if defined(FE_UNDERFLOW) || defined(RT_DEVICE_COMPILATION)584 if (flags & decimal::ConversionResultFlags::Underflow) {585 RAISE(FE_UNDERFLOW);586 }587#endif588#if defined(FE_INEXACT) || defined(RT_DEVICE_COMPILATION)589 if (flags & decimal::ConversionResultFlags::Inexact) {590 RAISE(FE_INEXACT);591 }592#endif593#if defined(FE_INVALID) || defined(RT_DEVICE_COMPILATION)594 if (flags & decimal::ConversionResultFlags::Invalid) {595 RAISE(FE_INVALID);596 }597#endif598#undef RAISE599}600 601// If no special modes are in effect and the form of the input value602// that's present in the input stream is acceptable to the decimal->binary603// converter without modification, this fast path for real input604// saves time by avoiding memory copies and reformatting of the exponent.605template <int PRECISION>606static RT_API_ATTRS bool TryFastPathRealDecimalInput(607 IoStatementState &io, const DataEdit &edit, void *n) {608 if (edit.modes.editingFlags & (blankZero | decimalComma)) {609 return false;610 }611 if (edit.modes.scale != 0) {612 return false;613 }614 const ConnectionState &connection{io.GetConnectionState()};615 if (connection.internalIoCharKind > 1) {616 return false; // reading non-default character617 }618 const char *str{nullptr};619 std::size_t got{io.GetNextInputBytes(str)};620 if (got == 0 || str == nullptr || !connection.recordLength.has_value()) {621 return false; // could not access reliably-terminated input stream622 }623 const char *p{str};624 std::int64_t maxConsume{625 std::min<std::int64_t>(got, edit.width.value_or(got))};626 const char *limit{str + maxConsume};627 decimal::ConversionToBinaryResult<PRECISION> converted{628 decimal::ConvertToBinary<PRECISION>(p, edit.modes.round, limit)};629 if (converted.flags & (decimal::Invalid | decimal::Overflow)) {630 return false;631 }632 if (edit.digits.value_or(0) != 0) {633 // Edit descriptor is Fw.d (or other) with d != 0, which634 // implies scaling635 const char *q{str};636 for (; q < limit; ++q) {637 if (*q == '.' || *q == 'n' || *q == 'N') {638 break;639 }640 }641 if (q == limit) {642 // No explicit decimal point, and not NaN/Inf.643 return false;644 }645 }646 if (edit.descriptor == DataEdit::ListDirectedImaginaryPart) {647 // Need to consume a trailing ')', possibly with leading spaces648 for (; p < limit && (*p == ' ' || *p == '\t'); ++p) {649 }650 if (p < limit && *p == ')') {651 ++p;652 } else {653 return false;654 }655 } else if (edit.IsListDirected()) {656 if (p < limit && !IsCharValueSeparator(edit, *p)) {657 return false;658 }659 } else {660 for (; p < limit && (*p == ' ' || *p == '\t'); ++p) {661 }662 if (edit.width && p < str + *edit.width) {663 return false; // unconverted characters remain in fixed width field664 }665 }666 // Success on the fast path!667 *reinterpret_cast<decimal::BinaryFloatingPointNumber<PRECISION> *>(n) =668 converted.binary;669 io.HandleRelativePosition(p - str);670 io.GotChar(p - str);671 // Set FP exception flags672 if (converted.flags != decimal::ConversionResultFlags::Exact) {673 RaiseFPExceptions(converted.flags);674 }675 return true;676}677 678template <int binaryPrecision>679RT_API_ATTRS decimal::ConversionToBinaryResult<binaryPrecision>680ConvertHexadecimal(681 const char *&p, enum decimal::FortranRounding rounding, int expo) {682 using RealType = decimal::BinaryFloatingPointNumber<binaryPrecision>;683 using RawType = typename RealType::RawType;684 bool isNegative{*p == '-'};685 constexpr RawType one{1};686 RawType signBit{0};687 if (isNegative) {688 ++p;689 signBit = one << (RealType::bits - 1);690 }691 RawType fraction{0};692 // Adjust the incoming binary P+/- exponent to shift the radix point693 // to below the LSB and add in the bias.694 expo += binaryPrecision - 1 + RealType::exponentBias;695 // Input the fraction.696 int roundingBit{0};697 int guardBit{0};698 for (; *p; ++p) {699 fraction <<= 4;700 expo -= 4;701 if (*p >= '0' && *p <= '9') {702 fraction |= *p - '0';703 } else if (*p >= 'A' && *p <= 'F') {704 fraction |= *p - 'A' + 10; // data were normalized to capitals705 } else {706 break;707 }708 if (fraction >> binaryPrecision) {709 while (fraction >> binaryPrecision) {710 guardBit |= roundingBit;711 roundingBit = (int)fraction & 1;712 fraction >>= 1;713 ++expo;714 }715 // Consume excess digits716 while (*++p) {717 if (*p == '0') {718 } else if ((*p >= '1' && *p <= '9') || (*p >= 'A' && *p <= 'F')) {719 guardBit = 1;720 } else {721 break;722 }723 }724 break;725 }726 }727 if (fraction) {728 // Boost biased expo if too small729 while (expo < 1) {730 guardBit |= roundingBit;731 roundingBit = (int)fraction & 1;732 fraction >>= 1;733 ++expo;734 }735 // Normalize736 while (expo > 1 && !(fraction >> (binaryPrecision - 1))) {737 fraction <<= 1;738 --expo;739 guardBit = roundingBit = 0;740 }741 }742 // Rounding743 bool increase{false};744 switch (rounding) {745 case decimal::RoundNearest: // RN & RP746 increase = roundingBit && (guardBit | ((int)fraction & 1));747 break;748 case decimal::RoundUp: // RU749 increase = !isNegative && (roundingBit | guardBit);750 break;751 case decimal::RoundDown: // RD752 increase = isNegative && (roundingBit | guardBit);753 break;754 case decimal::RoundToZero: // RZ755 break;756 case decimal::RoundCompatible: // RC757 increase = roundingBit != 0;758 break;759 }760 if (increase) {761 ++fraction;762 if (fraction >> binaryPrecision) {763 fraction >>= 1;764 ++expo;765 }766 }767 // Package & return result768 constexpr RawType significandMask{(one << RealType::significandBits) - 1};769 int flags{(roundingBit | guardBit) ? decimal::Inexact : decimal::Exact};770 if (!fraction) {771 expo = 0;772 } else if (expo == 1 && !(fraction >> (binaryPrecision - 1))) {773 expo = 0; // subnormal774 flags |= decimal::Underflow;775 } else if (expo >= RealType::maxExponent) {776 if (rounding == decimal::RoundToZero ||777 (rounding == decimal::RoundDown && !isNegative) ||778 (rounding == decimal::RoundUp && isNegative)) {779 expo = RealType::maxExponent - 1; // +/-HUGE()780 fraction = significandMask;781 } else {782 expo = RealType::maxExponent; // +/-Inf783 fraction = 0;784 flags |= decimal::Overflow;785 }786 } else {787 fraction &= significandMask; // remove explicit normalization unless x87788 }789 return decimal::ConversionToBinaryResult<binaryPrecision>{790 RealType{static_cast<RawType>(signBit |791 static_cast<RawType>(expo) << RealType::significandBits | fraction)},792 static_cast<decimal::ConversionResultFlags>(flags)};793}794 795template <int KIND>796RT_API_ATTRS bool EditCommonRealInput(797 IoStatementState &io, const DataEdit &edit, void *n) {798 constexpr int binaryPrecision{common::PrecisionOfRealKind(KIND)};799 if (TryFastPathRealDecimalInput<binaryPrecision>(io, edit, n)) {800 return CheckCompleteListDirectedField(io, edit);801 }802 // Fast path wasn't available or didn't work; go the more general route803 static constexpr int maxDigits{804 common::MaxDecimalConversionDigits(binaryPrecision)};805 static constexpr int bufferSize{maxDigits + 18};806 char buffer[bufferSize];807 auto scanned{ScanRealInput(buffer, maxDigits + 2, io, edit)};808 int got{scanned.got};809 if (got >= maxDigits + 2) {810 io.GetIoErrorHandler().Crash("EditCommonRealInput: buffer was too small");811 return false;812 }813 if (got == 0) {814 const auto &connection{io.GetConnectionState()};815 io.GetIoErrorHandler().SignalError(IostatBadRealInput,816 "Bad real input data at column %d of record %d",817 static_cast<int>(connection.positionInRecord + 1),818 static_cast<int>(connection.currentRecordNumber));819 return false;820 }821 decimal::ConversionToBinaryResult<binaryPrecision> converted;822 const char *p{buffer};823 if (scanned.isHexadecimal) {824 buffer[got] = '\0';825 converted = ConvertHexadecimal<binaryPrecision>(826 p, edit.modes.round, scanned.exponent);827 } else {828 bool hadExtra{got > maxDigits};829 int exponent{scanned.exponent};830 if (exponent != 0) {831 buffer[got++] = 'e';832 if (exponent < 0) {833 buffer[got++] = '-';834 exponent = -exponent;835 }836 if (exponent > 9999) {837 exponent = 9999; // will convert to +/-Inf838 }839 if (exponent > 999) {840 int dig{exponent / 1000};841 buffer[got++] = '0' + dig;842 int rest{exponent - 1000 * dig};843 dig = rest / 100;844 buffer[got++] = '0' + dig;845 rest -= 100 * dig;846 dig = rest / 10;847 buffer[got++] = '0' + dig;848 buffer[got++] = '0' + (rest - 10 * dig);849 } else if (exponent > 99) {850 int dig{exponent / 100};851 buffer[got++] = '0' + dig;852 int rest{exponent - 100 * dig};853 dig = rest / 10;854 buffer[got++] = '0' + dig;855 buffer[got++] = '0' + (rest - 10 * dig);856 } else if (exponent > 9) {857 int dig{exponent / 10};858 buffer[got++] = '0' + dig;859 buffer[got++] = '0' + (exponent - 10 * dig);860 } else {861 buffer[got++] = '0' + exponent;862 }863 }864 buffer[got] = '\0';865 converted = decimal::ConvertToBinary<binaryPrecision>(p, edit.modes.round);866 if (hadExtra) {867 converted.flags = static_cast<enum decimal::ConversionResultFlags>(868 converted.flags | decimal::Inexact);869 }870 }871 if (*p) { // unprocessed junk after value872 const auto &connection{io.GetConnectionState()};873 io.GetIoErrorHandler().SignalError(IostatBadRealInput,874 "Trailing characters after real input data at column %d of record %d",875 static_cast<int>(connection.positionInRecord + 1),876 static_cast<int>(connection.currentRecordNumber));877 return false;878 }879 *reinterpret_cast<decimal::BinaryFloatingPointNumber<binaryPrecision> *>(n) =880 converted.binary;881 // Set FP exception flags882 if (converted.flags != decimal::ConversionResultFlags::Exact) {883 if (converted.flags & decimal::ConversionResultFlags::Overflow) {884 io.GetIoErrorHandler().SignalError(IostatRealInputOverflow);885 return false;886 }887 RaiseFPExceptions(converted.flags);888 }889 return CheckCompleteListDirectedField(io, edit);890}891 892template <int KIND>893RT_API_ATTRS bool EditRealInput(894 IoStatementState &io, const DataEdit &edit, void *n) {895 switch (edit.descriptor) {896 case DataEdit::ListDirected:897 if (IsNamelistNameOrSlash(io)) {898 return false;899 }900 return EditCommonRealInput<KIND>(io, edit, n);901 case DataEdit::ListDirectedRealPart:902 case DataEdit::ListDirectedImaginaryPart:903 case 'F':904 case 'E': // incl. EN, ES, & EX905 case 'D':906 case 'G':907 return EditCommonRealInput<KIND>(io, edit, n);908 case 'B':909 return EditBOZInput<1>(io, edit, n,910 common::BitsForBinaryPrecision(common::PrecisionOfRealKind(KIND)) >> 3);911 case 'O':912 return EditBOZInput<3>(io, edit, n,913 common::BitsForBinaryPrecision(common::PrecisionOfRealKind(KIND)) >> 3);914 case 'Z':915 return EditBOZInput<4>(io, edit, n,916 common::BitsForBinaryPrecision(common::PrecisionOfRealKind(KIND)) >> 3);917 case 'A': // legacy extension918 return EditCharacterInput(io, edit, reinterpret_cast<char *>(n), KIND);919 default:920 io.GetIoErrorHandler().SignalError(IostatErrorInFormat,921 "Data edit descriptor '%c' may not be used for REAL input",922 edit.descriptor);923 return false;924 }925}926 927// 13.7.3 in Fortran 2018928RT_API_ATTRS bool EditLogicalInput(929 IoStatementState &io, const DataEdit &edit, bool &x) {930 switch (edit.descriptor) {931 case DataEdit::ListDirected:932 if (IsNamelistNameOrSlash(io)) {933 return false;934 }935 break;936 case 'L':937 case 'G':938 break;939 default:940 io.GetIoErrorHandler().SignalError(IostatErrorInFormat,941 "Data edit descriptor '%c' may not be used for LOGICAL input",942 edit.descriptor);943 return false;944 }945 common::optional<int> remaining{io.CueUpInput(edit)};946 common::optional<char32_t> next{io.NextInField(remaining, edit)};947 if (next && *next == '.') { // skip optional period948 next = io.NextInField(remaining, edit);949 }950 if (!next) {951 io.GetIoErrorHandler().SignalError("Empty LOGICAL input field");952 return false;953 }954 switch (*next) {955 case 'T':956 case 't':957 x = true;958 break;959 case 'F':960 case 'f':961 x = false;962 break;963 default:964 io.GetIoErrorHandler().SignalError(965 "Bad character '%lc' in LOGICAL input field", *next);966 return false;967 }968 if (remaining || edit.descriptor == DataEdit::ListDirected) {969 // Ignore the rest of the input field; stop after separator when970 // not list-directed.971 char32_t comma{edit.modes.GetSeparatorChar()};972 while (next && *next != comma) {973 next = io.NextInField(remaining, edit);974 }975 }976 return CheckCompleteListDirectedField(io, edit);977}978 979// See 13.10.3.1 paragraphs 7-9 in Fortran 2018980template <typename CHAR>981static RT_API_ATTRS bool EditDelimitedCharacterInput(982 IoStatementState &io, CHAR *x, std::size_t length, char32_t delimiter) {983 bool result{true};984 while (true) {985 std::size_t byteCount{0};986 auto ch{io.GetCurrentChar(byteCount)};987 if (!ch) {988 if (io.AdvanceRecord()) {989 continue;990 } else {991 result = false; // EOF in character value992 break;993 }994 }995 io.HandleRelativePosition(byteCount);996 if (*ch == delimiter) {997 auto next{io.GetCurrentChar(byteCount)};998 if (next && *next == delimiter) {999 // Repeated delimiter: use as character value1000 io.HandleRelativePosition(byteCount);1001 } else {1002 break; // closing delimiter1003 }1004 }1005 if (length > 0) {1006 *x++ = static_cast<CHAR>(*ch);1007 --length;1008 }1009 }1010 Fortran::runtime::fill_n(x, length, ' ');1011 return result;1012}1013 1014template <typename CHAR>1015static RT_API_ATTRS bool EditListDirectedCharacterInput(1016 IoStatementState &io, CHAR *x, std::size_t length, const DataEdit &edit) {1017 std::size_t byteCount{0};1018 auto ch{io.GetCurrentChar(byteCount)};1019 if (ch && (*ch == '\'' || *ch == '"')) {1020 io.HandleRelativePosition(byteCount);1021 return EditDelimitedCharacterInput(io, x, length, *ch);1022 }1023 if (IsNamelistNameOrSlash(io) || io.GetConnectionState().IsAtEOF()) {1024 return false;1025 }1026 // Undelimited list-directed character input: stop at a value separator1027 // or the end of the current record.1028 while (auto ch{io.GetCurrentChar(byteCount)}) {1029 if (IsCharValueSeparator(edit, *ch)) {1030 break;1031 }1032 if (length > 0) {1033 *x++ = static_cast<CHAR>(*ch);1034 --length;1035 } else if (edit.IsNamelist()) {1036 // GNU compatibility1037 break;1038 }1039 io.HandleRelativePosition(byteCount);1040 io.GotChar(byteCount);1041 }1042 Fortran::runtime::fill_n(x, length, ' ');1043 return true;1044}1045 1046template <typename CHAR>1047RT_API_ATTRS bool EditCharacterInput(IoStatementState &io, const DataEdit &edit,1048 CHAR *x, std::size_t lengthChars) {1049 switch (edit.descriptor) {1050 case DataEdit::ListDirected:1051 return EditListDirectedCharacterInput(io, x, lengthChars, edit);1052 case 'A':1053 case 'G':1054 break;1055 case 'B':1056 return EditBOZInput<1>(io, edit, x, lengthChars * sizeof *x);1057 case 'O':1058 return EditBOZInput<3>(io, edit, x, lengthChars * sizeof *x);1059 case 'Z':1060 return EditBOZInput<4>(io, edit, x, lengthChars * sizeof *x);1061 default:1062 io.GetIoErrorHandler().SignalError(IostatErrorInFormat,1063 "Data edit descriptor '%c' may not be used with a CHARACTER data item",1064 edit.descriptor);1065 return false;1066 }1067 const ConnectionState &connection{io.GetConnectionState()};1068 std::size_t remainingChars{lengthChars};1069 // Skip leading characters.1070 // Their bytes don't count towards INQUIRE(IOLENGTH=).1071 std::size_t skipChars{0};1072 if (edit.width && *edit.width > 0) {1073 remainingChars = *edit.width;1074 if (remainingChars > lengthChars) {1075 skipChars = remainingChars - lengthChars;1076 }1077 }1078 // When the field is wider than the variable, we drop the leading1079 // characters. When the variable is wider than the field, there can be1080 // trailing padding or an EOR condition.1081 const char *input{nullptr};1082 std::size_t readyBytes{0};1083 // Transfer payload bytes; these do count.1084 while (remainingChars > 0) {1085 if (readyBytes == 0) {1086 readyBytes = io.GetNextInputBytes(input);1087 if (readyBytes == 0 ||1088 (readyBytes < remainingChars && edit.modes.nonAdvancing)) {1089 if (io.CheckForEndOfRecord(readyBytes, connection)) {1090 if (readyBytes == 0) {1091 // PAD='YES' and no more data1092 Fortran::runtime::fill_n(x, lengthChars, ' ');1093 return !io.GetIoErrorHandler().InError();1094 } else {1095 // Do partial read(s) then pad on last iteration1096 }1097 } else {1098 return !io.GetIoErrorHandler().InError();1099 }1100 }1101 }1102 std::size_t chunkBytes;1103 std::size_t chunkChars{1};1104 bool skipping{skipChars > 0};1105 if (connection.isUTF8) {1106 chunkBytes = MeasureUTF8Bytes(*input);1107 if (skipping) {1108 --skipChars;1109 } else if (auto ucs{DecodeUTF8(input)}) {1110 if ((sizeof *x == 1 && *ucs > 0xff) ||1111 (sizeof *x == 2 && *ucs > 0xffff)) {1112 *x++ = '?';1113 } else {1114 *x++ = static_cast<CHAR>(*ucs);1115 }1116 --lengthChars;1117 } else if (chunkBytes == 0) {1118 // error recovery: skip bad encoding1119 chunkBytes = 1;1120 }1121 } else if (connection.internalIoCharKind > 1) {1122 // Reading from non-default character internal unit1123 chunkBytes = connection.internalIoCharKind;1124 if (skipping) {1125 --skipChars;1126 } else {1127 char32_t buffer{0};1128 runtime::memcpy(&buffer, input, chunkBytes);1129 if ((sizeof *x == 1 && buffer > 0xff) ||1130 (sizeof *x == 2 && buffer > 0xffff)) {1131 *x++ = '?';1132 } else {1133 *x++ = static_cast<CHAR>(buffer);1134 }1135 --lengthChars;1136 }1137 } else if constexpr (sizeof *x > 1) {1138 // Read single byte with expansion into multi-byte CHARACTER1139 chunkBytes = 1;1140 if (skipping) {1141 --skipChars;1142 } else {1143 *x++ = static_cast<unsigned char>(*input);1144 --lengthChars;1145 }1146 } else { // single bytes -> default CHARACTER1147 if (skipping) {1148 chunkBytes = std::min<std::size_t>(skipChars, readyBytes);1149 chunkChars = chunkBytes;1150 skipChars -= chunkChars;1151 } else {1152 chunkBytes = std::min<std::size_t>(remainingChars, readyBytes);1153 chunkBytes = std::min<std::size_t>(lengthChars, chunkBytes);1154 chunkChars = chunkBytes;1155 runtime::memcpy(x, input, chunkBytes);1156 x += chunkBytes;1157 lengthChars -= chunkChars;1158 }1159 }1160 input += chunkBytes;1161 remainingChars -= chunkChars;1162 if (!skipping) {1163 io.GotChar(chunkBytes);1164 }1165 io.HandleRelativePosition(chunkBytes);1166 readyBytes -= chunkBytes;1167 }1168 // Pad the remainder of the input variable, if any.1169 Fortran::runtime::fill_n(x, lengthChars, ' ');1170 return CheckCompleteListDirectedField(io, edit);1171}1172 1173template RT_API_ATTRS bool EditRealInput<2>(1174 IoStatementState &, const DataEdit &, void *);1175template RT_API_ATTRS bool EditRealInput<3>(1176 IoStatementState &, const DataEdit &, void *);1177template RT_API_ATTRS bool EditRealInput<4>(1178 IoStatementState &, const DataEdit &, void *);1179template RT_API_ATTRS bool EditRealInput<8>(1180 IoStatementState &, const DataEdit &, void *);1181template RT_API_ATTRS bool EditRealInput<10>(1182 IoStatementState &, const DataEdit &, void *);1183// TODO: double/double1184template RT_API_ATTRS bool EditRealInput<16>(1185 IoStatementState &, const DataEdit &, void *);1186 1187template RT_API_ATTRS bool EditCharacterInput(1188 IoStatementState &, const DataEdit &, char *, std::size_t);1189template RT_API_ATTRS bool EditCharacterInput(1190 IoStatementState &, const DataEdit &, char16_t *, std::size_t);1191template RT_API_ATTRS bool EditCharacterInput(1192 IoStatementState &, const DataEdit &, char32_t *, std::size_t);1193 1194RT_OFFLOAD_API_GROUP_END1195} // namespace Fortran::runtime::io1196