mirror of
https://github.com/llvm/llvm-project.git
synced 2025-04-17 03:26:48 +00:00
54f37133b7
Mostly mechanical changes in preparation of extracting the Flang-RT "subproject" in #110217. This PR intends to only move pre-existing files to the new folder structure, with no behavioral change. Common files (headers, testing, cmake) shared by Flang-RT and Flang remain in `flang/`. Some cosmetic changes and files paths were necessary: * Relative paths to the new path for the source files and `add_subdirectory`. * Add the new location's include directory to `include_directories` * The unittest/Evaluate directory has unitests for flang-rt and Flang. A new `CMakeLists.txt` was introduced for the flang-rt tests. * Change the `#include` paths relative to the include directive * clang-format on the `#include` directives * Since the paths are part if the copyright header and include guards, a script was used to canonicalize those * `test/Runtime` and runtime tests in `test/Driver` are moved, but the lit.cfg.py mechanism to execute the will only be added in #110217.
626 lines
22 KiB
C++
626 lines
22 KiB
C++
//===-- lib/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 "flang-rt/runtime/namelist.h"
|
|
#include "descriptor-io.h"
|
|
#include "flang-rt/runtime/emit-encoded.h"
|
|
#include "flang-rt/runtime/io-stmt.h"
|
|
#include "flang/Runtime/io-api.h"
|
|
#include <algorithm>
|
|
#include <cstring>
|
|
#include <limits>
|
|
|
|
namespace Fortran::runtime::io {
|
|
|
|
RT_VAR_GROUP_BEGIN
|
|
// Max size of a group, symbol or component identifier that can appear in
|
|
// NAMELIST input, plus a byte for NUL termination.
|
|
static constexpr RT_CONST_VAR_ATTRS std::size_t nameBufferSize{201};
|
|
RT_VAR_GROUP_END
|
|
|
|
RT_OFFLOAD_API_GROUP_BEGIN
|
|
|
|
static inline RT_API_ATTRS char32_t GetComma(IoStatementState &io) {
|
|
return io.mutableModes().editingFlags & decimalComma ? char32_t{';'}
|
|
: char32_t{','};
|
|
}
|
|
|
|
bool IODEF(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
|
|
IoStatementState &io{*cookie};
|
|
io.CheckFormattedStmtType<Direction::Output>("OutputNamelist");
|
|
io.mutableModes().inNamelist = true;
|
|
ConnectionState &connection{io.GetConnectionState()};
|
|
// The following lambda definition violates the conding style,
|
|
// but cuda-11.8 nvcc hits an internal error with the brace initialization.
|
|
|
|
// Internal function to advance records and convert case
|
|
const auto EmitUpperCase = [&](const char *prefix, std::size_t prefixLen,
|
|
const char *str, char suffix) -> bool {
|
|
if ((connection.NeedAdvance(prefixLen) &&
|
|
!(io.AdvanceRecord() && EmitAscii(io, " ", 1))) ||
|
|
!EmitAscii(io, prefix, prefixLen) ||
|
|
(connection.NeedAdvance(
|
|
Fortran::runtime::strlen(str) + (suffix != ' ')) &&
|
|
!(io.AdvanceRecord() && EmitAscii(io, " ", 1)))) {
|
|
return false;
|
|
}
|
|
for (; *str; ++str) {
|
|
char up{*str >= 'a' && *str <= 'z' ? static_cast<char>(*str - 'a' + 'A')
|
|
: *str};
|
|
if (!EmitAscii(io, &up, 1)) {
|
|
return false;
|
|
}
|
|
}
|
|
return suffix == ' ' || EmitAscii(io, &suffix, 1);
|
|
};
|
|
// &GROUP
|
|
if (!EmitUpperCase(" &", 2, group.groupName, ' ')) {
|
|
return false;
|
|
}
|
|
auto *listOutput{io.get_if<ListDirectedStatementState<Direction::Output>>()};
|
|
char comma{static_cast<char>(GetComma(io))};
|
|
char prefix{' '};
|
|
for (std::size_t j{0}; j < group.items; ++j) {
|
|
// [,]ITEM=...
|
|
const NamelistGroup::Item &item{group.item[j]};
|
|
if (listOutput) {
|
|
listOutput->set_lastWasUndelimitedCharacter(false);
|
|
}
|
|
if (!EmitUpperCase(&prefix, 1, item.name, '=')) {
|
|
return false;
|
|
}
|
|
prefix = comma;
|
|
if (const auto *addendum{item.descriptor.Addendum()};
|
|
addendum && addendum->derivedType()) {
|
|
const NonTbpDefinedIoTable *table{group.nonTbpDefinedIo};
|
|
if (!IONAME(OutputDerivedType)(cookie, item.descriptor, table)) {
|
|
return false;
|
|
}
|
|
} else if (!descr::DescriptorIO<Direction::Output>(io, item.descriptor)) {
|
|
return false;
|
|
}
|
|
}
|
|
// terminal /
|
|
return EmitUpperCase("/", 1, "", ' ');
|
|
}
|
|
|
|
static constexpr RT_API_ATTRS bool IsLegalIdStart(char32_t ch) {
|
|
return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || ch == '_' ||
|
|
ch == '@';
|
|
}
|
|
|
|
static constexpr RT_API_ATTRS bool IsLegalIdChar(char32_t ch) {
|
|
return IsLegalIdStart(ch) || (ch >= '0' && ch <= '9');
|
|
}
|
|
|
|
static constexpr RT_API_ATTRS char NormalizeIdChar(char32_t ch) {
|
|
return static_cast<char>(ch >= 'A' && ch <= 'Z' ? ch - 'A' + 'a' : ch);
|
|
}
|
|
|
|
static RT_API_ATTRS bool GetLowerCaseName(
|
|
IoStatementState &io, char buffer[], std::size_t maxLength) {
|
|
std::size_t byteLength{0};
|
|
if (auto ch{io.GetNextNonBlank(byteLength)}) {
|
|
if (IsLegalIdStart(*ch)) {
|
|
std::size_t j{0};
|
|
do {
|
|
buffer[j] = NormalizeIdChar(*ch);
|
|
io.HandleRelativePosition(byteLength);
|
|
ch = io.GetCurrentChar(byteLength);
|
|
} while (++j < maxLength && ch && IsLegalIdChar(*ch));
|
|
buffer[j++] = '\0';
|
|
if (j <= maxLength) {
|
|
return true;
|
|
}
|
|
io.GetIoErrorHandler().SignalError(
|
|
"Identifier '%s...' in NAMELIST input group is too long", buffer);
|
|
}
|
|
}
|
|
return false;
|
|
}
|
|
|
|
static RT_API_ATTRS Fortran::common::optional<SubscriptValue> GetSubscriptValue(
|
|
IoStatementState &io) {
|
|
Fortran::common::optional<SubscriptValue> value;
|
|
std::size_t byteCount{0};
|
|
Fortran::common::optional<char32_t> ch{io.GetCurrentChar(byteCount)};
|
|
bool negate{ch && *ch == '-'};
|
|
if ((ch && *ch == '+') || negate) {
|
|
io.HandleRelativePosition(byteCount);
|
|
ch = io.GetCurrentChar(byteCount);
|
|
}
|
|
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(byteCount);
|
|
ch = io.GetCurrentChar(byteCount);
|
|
}
|
|
if (overflow) {
|
|
io.GetIoErrorHandler().SignalError(
|
|
"NAMELIST input subscript value overflow");
|
|
return Fortran::common::nullopt;
|
|
}
|
|
if (negate) {
|
|
if (value) {
|
|
return -*value;
|
|
} else {
|
|
io.HandleRelativePosition(-byteCount); // give back '-' with no digits
|
|
}
|
|
}
|
|
return value;
|
|
}
|
|
|
|
static RT_API_ATTRS bool HandleSubscripts(IoStatementState &io,
|
|
Descriptor &desc, const Descriptor &source, const char *name) {
|
|
IoErrorHandler &handler{io.GetIoErrorHandler()};
|
|
// Allow for blanks in subscripts; they're nonstandard, but not
|
|
// ambiguous within the parentheses.
|
|
SubscriptValue lower[maxRank], upper[maxRank], stride[maxRank];
|
|
int j{0};
|
|
std::size_t contiguousStride{source.ElementBytes()};
|
|
bool ok{true};
|
|
std::size_t byteCount{0};
|
|
Fortran::common::optional<char32_t> ch{io.GetNextNonBlank(byteCount)};
|
|
char32_t comma{GetComma(io)};
|
|
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 =
|
|
dim.ByteStride() / std::max<SubscriptValue>(contiguousStride, 1);
|
|
contiguousStride *= dim.Extent();
|
|
} 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(byteCount);
|
|
}
|
|
if (ch && *ch == ':') {
|
|
io.HandleRelativePosition(byteCount);
|
|
ch = io.GetNextNonBlank(byteCount);
|
|
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(byteCount);
|
|
}
|
|
if (ch && *ch == ':') {
|
|
io.HandleRelativePosition(byteCount);
|
|
ch = io.GetNextNonBlank(byteCount);
|
|
if (auto str{GetSubscriptValue(io)}) {
|
|
dimStride = *str;
|
|
ch = io.GetNextNonBlank(byteCount);
|
|
}
|
|
}
|
|
} else { // scalar
|
|
dimUpper = dimLower;
|
|
dimStride = 0;
|
|
}
|
|
if (ch && *ch == comma) {
|
|
io.HandleRelativePosition(byteCount);
|
|
ch = io.GetNextNonBlank(byteCount);
|
|
}
|
|
if (ok) {
|
|
lower[j] = dimLower;
|
|
upper[j] = dimUpper;
|
|
stride[j] = dimStride;
|
|
}
|
|
}
|
|
if (ok) {
|
|
if (ch && *ch == ')') {
|
|
io.HandleRelativePosition(byteCount);
|
|
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;
|
|
}
|
|
|
|
static RT_API_ATTRS void StorageSequenceExtension(
|
|
Descriptor &desc, const Descriptor &source) {
|
|
// Support the near-universal extension of NAMELIST input into a
|
|
// designatable storage sequence identified by its initial scalar array
|
|
// element. For example, treat "A(1) = 1. 2. 3." as if it had been
|
|
// "A(1:) = 1. 2. 3.".
|
|
if (desc.rank() == 0 && (source.rank() == 1 || source.IsContiguous())) {
|
|
if (auto stride{source.rank() == 1
|
|
? source.GetDimension(0).ByteStride()
|
|
: static_cast<SubscriptValue>(source.ElementBytes())};
|
|
stride != 0) {
|
|
desc.raw().attribute = CFI_attribute_pointer;
|
|
desc.raw().rank = 1;
|
|
desc.GetDimension(0)
|
|
.SetBounds(1,
|
|
source.Elements() -
|
|
((source.OffsetElement() - desc.OffsetElement()) / stride))
|
|
.SetByteStride(stride);
|
|
}
|
|
}
|
|
}
|
|
|
|
static RT_API_ATTRS bool HandleSubstring(
|
|
IoStatementState &io, Descriptor &desc, const char *name) {
|
|
IoErrorHandler &handler{io.GetIoErrorHandler()};
|
|
auto pair{desc.type().GetCategoryAndKind()};
|
|
if (!pair || pair->first != TypeCategory::Character) {
|
|
handler.SignalError("Substring reference to non-character item '%s'", name);
|
|
return false;
|
|
}
|
|
int kind{pair->second};
|
|
SubscriptValue chars{static_cast<SubscriptValue>(desc.ElementBytes()) / kind};
|
|
// Allow for blanks in substring bounds; they're nonstandard, but not
|
|
// ambiguous within the parentheses.
|
|
Fortran::common::optional<SubscriptValue> lower, upper;
|
|
std::size_t byteCount{0};
|
|
Fortran::common::optional<char32_t> ch{io.GetNextNonBlank(byteCount)};
|
|
if (ch) {
|
|
if (*ch == ':') {
|
|
lower = 1;
|
|
} else {
|
|
lower = GetSubscriptValue(io);
|
|
ch = io.GetNextNonBlank(byteCount);
|
|
}
|
|
}
|
|
if (ch && *ch == ':') {
|
|
io.HandleRelativePosition(byteCount);
|
|
ch = io.GetNextNonBlank(byteCount);
|
|
if (ch) {
|
|
if (*ch == ')') {
|
|
upper = chars;
|
|
} else {
|
|
upper = GetSubscriptValue(io);
|
|
ch = io.GetNextNonBlank(byteCount);
|
|
}
|
|
}
|
|
}
|
|
if (ch && *ch == ')') {
|
|
io.HandleRelativePosition(byteCount);
|
|
if (lower && upper) {
|
|
if (*lower > *upper) {
|
|
// An empty substring, whatever the values are
|
|
desc.raw().elem_len = 0;
|
|
return true;
|
|
}
|
|
if (*lower >= 1 && *upper <= chars) {
|
|
// Offset the base address & adjust the element byte length
|
|
desc.raw().elem_len = (*upper - *lower + 1) * kind;
|
|
desc.set_base_addr(reinterpret_cast<void *>(
|
|
reinterpret_cast<char *>(desc.raw().base_addr) +
|
|
kind * (*lower - 1)));
|
|
return true;
|
|
}
|
|
}
|
|
handler.SignalError(
|
|
"Bad substring bounds for NAMELIST input group item '%s'", name);
|
|
} else {
|
|
handler.SignalError(
|
|
"Bad substring (missing ')') for NAMELIST input group item '%s'", name);
|
|
}
|
|
return false;
|
|
}
|
|
|
|
static RT_API_ATTRS bool HandleComponent(IoStatementState &io, Descriptor &desc,
|
|
const Descriptor &source, const char *name) {
|
|
IoErrorHandler &handler{io.GetIoErrorHandler()};
|
|
char compName[nameBufferSize];
|
|
if (GetLowerCaseName(io, compName, sizeof compName)) {
|
|
const DescriptorAddendum *addendum{source.Addendum()};
|
|
if (const typeInfo::DerivedType *
|
|
type{addendum ? addendum->derivedType() : nullptr}) {
|
|
if (const typeInfo::Component *
|
|
comp{type->FindDataComponent(
|
|
compName, Fortran::runtime::strlen(compName))}) {
|
|
bool createdDesc{false};
|
|
if (comp->rank() > 0 && source.rank() > 0) {
|
|
// If base and component are both arrays, the component name
|
|
// must be followed by subscripts; process them now.
|
|
std::size_t byteCount{0};
|
|
if (Fortran::common::optional<char32_t> next{
|
|
io.GetNextNonBlank(byteCount)};
|
|
next && *next == '(') {
|
|
io.HandleRelativePosition(byteCount); // skip over '('
|
|
StaticDescriptor<maxRank, true, 16> staticDesc;
|
|
Descriptor &tmpDesc{staticDesc.descriptor()};
|
|
comp->CreatePointerDescriptor(tmpDesc, source, handler);
|
|
if (!HandleSubscripts(io, desc, tmpDesc, compName)) {
|
|
return false;
|
|
}
|
|
createdDesc = true;
|
|
}
|
|
}
|
|
if (!createdDesc) {
|
|
comp->CreatePointerDescriptor(desc, source, handler);
|
|
}
|
|
if (source.rank() > 0) {
|
|
if (desc.rank() > 0) {
|
|
handler.SignalError(
|
|
"NAMELIST component reference '%%%s' of input group "
|
|
"item %s cannot be an array when its base is not scalar",
|
|
compName, name);
|
|
return false;
|
|
}
|
|
desc.raw().rank = source.rank();
|
|
for (int j{0}; j < source.rank(); ++j) {
|
|
const auto &srcDim{source.GetDimension(j)};
|
|
desc.GetDimension(j)
|
|
.SetBounds(1, srcDim.UpperBound())
|
|
.SetByteStride(srcDim.ByteStride());
|
|
}
|
|
}
|
|
return true;
|
|
} else {
|
|
handler.SignalError(
|
|
"NAMELIST component reference '%%%s' of input group item %s is not "
|
|
"a component of its derived type",
|
|
compName, name);
|
|
}
|
|
} else if (source.type().IsDerived()) {
|
|
handler.Crash("Derived type object '%s' in NAMELIST is missing its "
|
|
"derived type information!",
|
|
name);
|
|
} else {
|
|
handler.SignalError("NAMELIST component reference '%%%s' of input group "
|
|
"item %s for non-derived type",
|
|
compName, name);
|
|
}
|
|
} else {
|
|
handler.SignalError("NAMELIST component reference of input group item %s "
|
|
"has no name after '%%'",
|
|
name);
|
|
}
|
|
return false;
|
|
}
|
|
|
|
// Advance to the terminal '/' of a namelist group or leading '&'/'$'
|
|
// of the next.
|
|
static RT_API_ATTRS void SkipNamelistGroup(IoStatementState &io) {
|
|
std::size_t byteCount{0};
|
|
while (auto ch{io.GetNextNonBlank(byteCount)}) {
|
|
io.HandleRelativePosition(byteCount);
|
|
if (*ch == '/' || *ch == '&' || *ch == '$') {
|
|
break;
|
|
} else if (*ch == '\'' || *ch == '"') {
|
|
// Skip quoted character literal
|
|
char32_t quote{*ch};
|
|
while (true) {
|
|
if ((ch = io.GetCurrentChar(byteCount))) {
|
|
io.HandleRelativePosition(byteCount);
|
|
if (*ch == quote) {
|
|
break;
|
|
}
|
|
} else if (!io.AdvanceRecord()) {
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
bool IODEF(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
|
|
IoStatementState &io{*cookie};
|
|
io.CheckFormattedStmtType<Direction::Input>("InputNamelist");
|
|
io.mutableModes().inNamelist = true;
|
|
IoErrorHandler &handler{io.GetIoErrorHandler()};
|
|
auto *listInput{io.get_if<ListDirectedStatementState<Direction::Input>>()};
|
|
RUNTIME_CHECK(handler, listInput != nullptr);
|
|
// Find this namelist group's header in the input
|
|
io.BeginReadingRecord();
|
|
Fortran::common::optional<char32_t> next;
|
|
char name[nameBufferSize];
|
|
RUNTIME_CHECK(handler, group.groupName != nullptr);
|
|
char32_t comma{GetComma(io)};
|
|
std::size_t byteCount{0};
|
|
while (true) {
|
|
next = io.GetNextNonBlank(byteCount);
|
|
while (next && *next != '&' && *next != '$') {
|
|
// Extension: comment lines without ! before namelist groups
|
|
if (!io.AdvanceRecord()) {
|
|
next.reset();
|
|
} else {
|
|
next = io.GetNextNonBlank(byteCount);
|
|
}
|
|
}
|
|
if (!next) {
|
|
handler.SignalEnd();
|
|
return false;
|
|
}
|
|
if (*next != '&' && *next != '$') {
|
|
handler.SignalError(
|
|
"NAMELIST input group does not begin with '&' or '$' (at '%lc')",
|
|
*next);
|
|
return false;
|
|
}
|
|
io.HandleRelativePosition(byteCount);
|
|
if (!GetLowerCaseName(io, name, sizeof name)) {
|
|
handler.SignalError("NAMELIST input group has no name");
|
|
return false;
|
|
}
|
|
if (Fortran::runtime::strcmp(group.groupName, name) == 0) {
|
|
break; // found it
|
|
}
|
|
SkipNamelistGroup(io);
|
|
}
|
|
// Read the group's items
|
|
while (true) {
|
|
next = io.GetNextNonBlank(byteCount);
|
|
if (!next || *next == '/' || *next == '&' || *next == '$') {
|
|
break;
|
|
}
|
|
if (!GetLowerCaseName(io, name, sizeof name)) {
|
|
handler.SignalError(
|
|
"NAMELIST input group '%s' was not terminated at '%c'",
|
|
group.groupName, static_cast<char>(*next));
|
|
return false;
|
|
}
|
|
std::size_t itemIndex{0};
|
|
for (; itemIndex < group.items; ++itemIndex) {
|
|
if (Fortran::runtime::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(byteCount);
|
|
bool hadSubscripts{false};
|
|
bool hadSubstring{false};
|
|
if (next && (*next == '(' || *next == '%')) {
|
|
const Descriptor *lastSubscriptBase{nullptr};
|
|
Descriptor *lastSubscriptDescriptor{nullptr};
|
|
do {
|
|
Descriptor &mutableDescriptor{staticDesc[whichStaticDesc].descriptor()};
|
|
whichStaticDesc ^= 1;
|
|
io.HandleRelativePosition(byteCount); // skip over '(' or '%'
|
|
lastSubscriptDescriptor = nullptr;
|
|
lastSubscriptBase = nullptr;
|
|
if (*next == '(') {
|
|
if (!hadSubstring && (hadSubscripts || useDescriptor->rank() == 0)) {
|
|
mutableDescriptor = *useDescriptor;
|
|
mutableDescriptor.raw().attribute = CFI_attribute_pointer;
|
|
if (!HandleSubstring(io, mutableDescriptor, name)) {
|
|
return false;
|
|
}
|
|
hadSubstring = true;
|
|
} else if (hadSubscripts) {
|
|
handler.SignalError("Multiple sets of subscripts for item '%s' in "
|
|
"NAMELIST group '%s'",
|
|
name, group.groupName);
|
|
return false;
|
|
} else if (HandleSubscripts(
|
|
io, mutableDescriptor, *useDescriptor, name)) {
|
|
lastSubscriptBase = useDescriptor;
|
|
lastSubscriptDescriptor = &mutableDescriptor;
|
|
} else {
|
|
return false;
|
|
}
|
|
hadSubscripts = true;
|
|
} else {
|
|
if (!HandleComponent(io, mutableDescriptor, *useDescriptor, name)) {
|
|
return false;
|
|
}
|
|
hadSubscripts = false;
|
|
hadSubstring = false;
|
|
}
|
|
useDescriptor = &mutableDescriptor;
|
|
next = io.GetCurrentChar(byteCount);
|
|
} while (next && (*next == '(' || *next == '%'));
|
|
if (lastSubscriptDescriptor) {
|
|
StorageSequenceExtension(*lastSubscriptDescriptor, *lastSubscriptBase);
|
|
}
|
|
}
|
|
// Skip the '='
|
|
next = io.GetNextNonBlank(byteCount);
|
|
if (!next || *next != '=') {
|
|
handler.SignalError("No '=' found after item '%s' in NAMELIST group '%s'",
|
|
name, group.groupName);
|
|
return false;
|
|
}
|
|
io.HandleRelativePosition(byteCount);
|
|
// Read the values into the descriptor. An array can be short.
|
|
if (const auto *addendum{useDescriptor->Addendum()};
|
|
addendum && addendum->derivedType()) {
|
|
const NonTbpDefinedIoTable *table{group.nonTbpDefinedIo};
|
|
listInput->ResetForNextNamelistItem(/*inNamelistSequence=*/true);
|
|
if (!IONAME(InputDerivedType)(cookie, *useDescriptor, table)) {
|
|
return false;
|
|
}
|
|
} else {
|
|
listInput->ResetForNextNamelistItem(useDescriptor->rank() > 0);
|
|
if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) {
|
|
return false;
|
|
}
|
|
}
|
|
next = io.GetNextNonBlank(byteCount);
|
|
if (next && *next == comma) {
|
|
io.HandleRelativePosition(byteCount);
|
|
}
|
|
}
|
|
if (next && *next == '/') {
|
|
io.HandleRelativePosition(byteCount);
|
|
} else if (*next && (*next == '&' || *next == '$')) {
|
|
// stop at beginning of next group
|
|
} else {
|
|
handler.SignalError(
|
|
"No '/' found after NAMELIST group '%s'", group.groupName);
|
|
return false;
|
|
}
|
|
return true;
|
|
}
|
|
|
|
RT_API_ATTRS bool IsNamelistNameOrSlash(IoStatementState &io) {
|
|
if (auto *listInput{
|
|
io.get_if<ListDirectedStatementState<Direction::Input>>()}) {
|
|
if (listInput->inNamelistSequence()) {
|
|
SavedPosition savedPosition{io};
|
|
std::size_t byteCount{0};
|
|
if (auto ch{io.GetNextNonBlank(byteCount)}) {
|
|
if (IsLegalIdStart(*ch)) {
|
|
do {
|
|
io.HandleRelativePosition(byteCount);
|
|
ch = io.GetCurrentChar(byteCount);
|
|
} while (ch && IsLegalIdChar(*ch));
|
|
ch = io.GetNextNonBlank(byteCount);
|
|
// TODO: how to deal with NaN(...) ambiguity?
|
|
return ch && (*ch == '=' || *ch == '(' || *ch == '%');
|
|
} else {
|
|
return *ch == '/' || *ch == '&' || *ch == '$';
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return false;
|
|
}
|
|
|
|
RT_OFFLOAD_API_GROUP_END
|
|
|
|
} // namespace Fortran::runtime::io
|