aec90f2f27
When NAMELIST input takes place on a derived type, we need to preserve the type in the descriptor that is created for storage sequence association. Further, the fact that any child list input in within the context of a NAMELIST must be inherited so that input fields don't try to consume later "variable=" strings. Fixes https://github.com/llvm/llvm-project/issues/151222.
634 lines
22 KiB
C++
634 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-rt/runtime/type-info.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().GetSeparatorChar();
|
|
}
|
|
|
|
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) {
|
|
common::optional<DescriptorAddendum> savedAddendum;
|
|
if (const DescriptorAddendum *addendum{desc.Addendum()}) {
|
|
// Preserve a copy of the addendum, if any, before clobbering it
|
|
savedAddendum.emplace(*addendum);
|
|
}
|
|
desc.raw().attribute = CFI_attribute_pointer;
|
|
desc.raw().rank = 1;
|
|
desc.GetDimension(0)
|
|
.SetBounds(1,
|
|
source.Elements() -
|
|
((source.OffsetElement() - desc.OffsetElement()) / stride))
|
|
.SetByteStride(stride);
|
|
if (savedAddendum) {
|
|
*desc.Addendum() = *savedAddendum;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
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
|