| //===-- runtime/namelist.cpp ------------------------------------*- C++ -*-===// |
| // |
| // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
| // See https://llvm.org/LICENSE.txt for license information. |
| // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
| // |
| //===----------------------------------------------------------------------===// |
| |
| #include "namelist.h" |
| #include "descriptor-io.h" |
| #include "io-api.h" |
| #include "io-stmt.h" |
| #include <cstring> |
| #include <limits> |
| |
| namespace Fortran::runtime::io { |
| |
| bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) { |
| IoStatementState &io{*cookie}; |
| io.CheckFormattedStmtType<Direction::Output>("OutputNamelist"); |
| ConnectionState &connection{io.GetConnectionState()}; |
| connection.modes.inNamelist = true; |
| // Internal functions to advance records and convert case |
| const auto EmitWithAdvance{[&](char ch) -> bool { |
| return (!connection.NeedAdvance(1) || io.AdvanceRecord()) && |
| io.Emit(&ch, 1); |
| }}; |
| const auto EmitUpperCase{[&](const char *str) -> bool { |
| if (connection.NeedAdvance(std::strlen(str)) && |
| !(io.AdvanceRecord() && io.Emit(" ", 1))) { |
| return false; |
| } |
| for (; *str; ++str) { |
| char up{*str >= 'a' && *str <= 'z' ? static_cast<char>(*str - 'a' + 'A') |
| : *str}; |
| if (!io.Emit(&up, 1)) { |
| return false; |
| } |
| } |
| return true; |
| }}; |
| // &GROUP |
| if (!(EmitWithAdvance('&') && EmitUpperCase(group.groupName))) { |
| return false; |
| } |
| for (std::size_t j{0}; j < group.items; ++j) { |
| // [,]ITEM=... |
| const NamelistGroup::Item &item{group.item[j]}; |
| if (!(EmitWithAdvance(j == 0 ? ' ' : ',') && EmitUpperCase(item.name) && |
| EmitWithAdvance('=') && |
| descr::DescriptorIO<Direction::Output>(io, item.descriptor))) { |
| return false; |
| } |
| } |
| // terminal / |
| return EmitWithAdvance('/'); |
| } |
| |
| static bool GetLowerCaseName( |
| IoStatementState &io, char buffer[], std::size_t maxLength) { |
| if (auto ch{io.GetCurrentChar()}) { |
| static const auto IsLegalIdStart{[](char32_t ch) -> bool { |
| return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || |
| ch == '_' || ch == '@' || ch == '$'; |
| }}; |
| if (IsLegalIdStart(*ch)) { |
| std::size_t j{0}; |
| do { |
| buffer[j] = |
| static_cast<char>(*ch >= 'A' && *ch <= 'Z' ? *ch - 'A' + 'a' : *ch); |
| io.HandleRelativePosition(1); |
| ch = io.GetCurrentChar(); |
| } while (++j < maxLength && ch && |
| (IsLegalIdStart(*ch) || (*ch >= '0' && *ch <= '9'))); |
| buffer[j++] = '\0'; |
| if (j <= maxLength) { |
| return true; |
| } |
| io.GetIoErrorHandler().SignalError( |
| "Identifier '%s...' in NAMELIST input group is too long", buffer); |
| } |
| } |
| return false; |
| } |
| |
| static std::optional<SubscriptValue> GetSubscriptValue(IoStatementState &io) { |
| std::optional<SubscriptValue> value; |
| std::optional<char32_t> ch{io.GetCurrentChar()}; |
| bool negate{ch && *ch == '-'}; |
| if (negate) { |
| io.HandleRelativePosition(1); |
| ch = io.GetCurrentChar(); |
| } |
| bool overflow{false}; |
| while (ch && *ch >= '0' && *ch <= '9') { |
| SubscriptValue was{value.value_or(0)}; |
| overflow |= was >= std::numeric_limits<SubscriptValue>::max() / 10; |
| value = 10 * was + *ch - '0'; |
| io.HandleRelativePosition(1); |
| ch = io.GetCurrentChar(); |
| } |
| if (overflow) { |
| io.GetIoErrorHandler().SignalError( |
| "NAMELIST input subscript value overflow"); |
| return std::nullopt; |
| } |
| if (negate) { |
| if (value) { |
| return -*value; |
| } else { |
| io.HandleRelativePosition(-1); // give back '-' with no digits |
| } |
| } |
| return value; |
| } |
| |
| static bool HandleSubscripts(IoStatementState &io, Descriptor &desc, |
| const Descriptor &source, const char *name) { |
| IoErrorHandler &handler{io.GetIoErrorHandler()}; |
| io.HandleRelativePosition(1); // skip '(' |
| // Allow for blanks in subscripts; it's nonstandard, but not ambiguous |
| // within the parentheses |
| SubscriptValue lower[maxRank], upper[maxRank], stride[maxRank]; |
| int j{0}; |
| std::size_t elemLen{source.ElementBytes()}; |
| bool ok{true}; |
| std::optional<char32_t> ch{io.GetNextNonBlank()}; |
| for (; ch && *ch != ')'; ++j) { |
| SubscriptValue dimLower{0}, dimUpper{0}, dimStride{0}; |
| if (j < maxRank && j < source.rank()) { |
| const Dimension &dim{source.GetDimension(j)}; |
| dimLower = dim.LowerBound(); |
| dimUpper = dim.UpperBound(); |
| dimStride = elemLen ? dim.ByteStride() / elemLen : 1; |
| } else if (ok) { |
| handler.SignalError( |
| "Too many subscripts for rank-%d NAMELIST group item '%s'", |
| source.rank(), name); |
| ok = false; |
| } |
| if (auto low{GetSubscriptValue(io)}) { |
| if (*low < dimLower || (dimUpper >= dimLower && *low > dimUpper)) { |
| if (ok) { |
| handler.SignalError("Subscript %jd out of range %jd..%jd in NAMELIST " |
| "group item '%s' dimension %d", |
| static_cast<std::intmax_t>(*low), |
| static_cast<std::intmax_t>(dimLower), |
| static_cast<std::intmax_t>(dimUpper), name, j + 1); |
| ok = false; |
| } |
| } else { |
| dimLower = *low; |
| } |
| ch = io.GetNextNonBlank(); |
| } |
| if (ch && *ch == ':') { |
| io.HandleRelativePosition(1); |
| ch = io.GetNextNonBlank(); |
| if (auto high{GetSubscriptValue(io)}) { |
| if (*high > dimUpper) { |
| if (ok) { |
| handler.SignalError( |
| "Subscript triplet upper bound %jd out of range (>%jd) in " |
| "NAMELIST group item '%s' dimension %d", |
| static_cast<std::intmax_t>(*high), |
| static_cast<std::intmax_t>(dimUpper), name, j + 1); |
| ok = false; |
| } |
| } else { |
| dimUpper = *high; |
| } |
| ch = io.GetNextNonBlank(); |
| } |
| if (ch && *ch == ':') { |
| io.HandleRelativePosition(1); |
| ch = io.GetNextNonBlank(); |
| if (auto str{GetSubscriptValue(io)}) { |
| dimStride = *str; |
| ch = io.GetNextNonBlank(); |
| } |
| } |
| } else { // scalar |
| dimUpper = dimLower; |
| dimStride = 0; |
| } |
| if (ch && *ch == ',') { |
| io.HandleRelativePosition(1); |
| ch = io.GetNextNonBlank(); |
| } |
| if (ok) { |
| lower[j] = dimLower; |
| upper[j] = dimUpper; |
| stride[j] = dimStride; |
| } |
| } |
| if (ok) { |
| if (ch && *ch == ')') { |
| io.HandleRelativePosition(1); |
| if (desc.EstablishPointerSection(source, lower, upper, stride)) { |
| return true; |
| } else { |
| handler.SignalError( |
| "Bad subscripts for NAMELIST input group item '%s'", name); |
| } |
| } else { |
| handler.SignalError( |
| "Bad subscripts (missing ')') for NAMELIST input group item '%s'", |
| name); |
| } |
| } |
| return false; |
| } |
| |
| bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) { |
| IoStatementState &io{*cookie}; |
| io.CheckFormattedStmtType<Direction::Input>("InputNamelist"); |
| ConnectionState &connection{io.GetConnectionState()}; |
| connection.modes.inNamelist = true; |
| IoErrorHandler &handler{io.GetIoErrorHandler()}; |
| // Check the group header |
| std::optional<char32_t> next{io.GetNextNonBlank()}; |
| if (!next || *next != '&') { |
| handler.SignalError( |
| "NAMELIST input group does not begin with '&' (at '%lc')", *next); |
| return false; |
| } |
| io.HandleRelativePosition(1); |
| char name[101]; |
| if (!GetLowerCaseName(io, name, sizeof name)) { |
| handler.SignalError("NAMELIST input group has no name"); |
| return false; |
| } |
| RUNTIME_CHECK(handler, group.groupName != nullptr); |
| if (std::strcmp(group.groupName, name) != 0) { |
| handler.SignalError( |
| "NAMELIST input group name '%s' is not the expected '%s'", name, |
| group.groupName); |
| return false; |
| } |
| // Read the group's items |
| while (true) { |
| next = io.GetNextNonBlank(); |
| if (!next || *next == '/') { |
| break; |
| } |
| if (!GetLowerCaseName(io, name, sizeof name)) { |
| handler.SignalError( |
| "NAMELIST input group '%s' was not terminated", group.groupName); |
| return false; |
| } |
| std::size_t itemIndex{0}; |
| for (; itemIndex < group.items; ++itemIndex) { |
| if (std::strcmp(name, group.item[itemIndex].name) == 0) { |
| break; |
| } |
| } |
| if (itemIndex >= group.items) { |
| handler.SignalError( |
| "'%s' is not an item in NAMELIST group '%s'", name, group.groupName); |
| return false; |
| } |
| // Handle indexing and components, if any. No spaces are allowed. |
| // A copy of the descriptor is made if necessary. |
| const Descriptor &itemDescriptor{group.item[itemIndex].descriptor}; |
| const Descriptor *useDescriptor{&itemDescriptor}; |
| StaticDescriptor<maxRank, true, 16> staticDesc[2]; |
| int whichStaticDesc{0}; |
| next = io.GetCurrentChar(); |
| if (next && (*next == '(' || *next == '%')) { |
| do { |
| if (*next == '(') { |
| Descriptor &mutableDescriptor{ |
| staticDesc[whichStaticDesc].descriptor()}; |
| whichStaticDesc ^= 1; |
| HandleSubscripts(io, mutableDescriptor, *useDescriptor, name); |
| useDescriptor = &mutableDescriptor; |
| } else { |
| handler.Crash("unimplemented: component references in NAMELIST"); |
| } |
| next = io.GetCurrentChar(); |
| } while (next && (*next == '(' || *next == '%')); |
| } |
| // Skip the '=' |
| next = io.GetNextNonBlank(); |
| if (!next || *next != '=') { |
| handler.SignalError("No '=' found after item '%s' in NAMELIST group '%s'", |
| name, group.groupName); |
| return false; |
| } |
| io.HandleRelativePosition(1); |
| // Read the values into the descriptor |
| if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) { |
| return false; |
| } |
| next = io.GetNextNonBlank(); |
| if (next && *next == ',') { |
| io.HandleRelativePosition(1); |
| } |
| } |
| if (!next || *next != '/') { |
| handler.SignalError( |
| "No '/' found after NAMELIST group '%s'", group.groupName); |
| return false; |
| } |
| io.HandleRelativePosition(1); |
| return true; |
| } |
| |
| } // namespace Fortran::runtime::io |