2bf3ccabfa
Recursion, both direct and indirect, prevents accurate stack size calculation at link time for GPU device code. Restructure these recursive (often mutually so) routines in the Fortran runtime with new implementations based on an iterative work queue with suspendable/resumable work tickets: Assign, Initialize, initializeClone, Finalize, and Destroy. Default derived type I/O is also recursive, but already disabled. It can be added to this new framework later if the overall approach succeeds. Note that derived type FINAL subroutine calls, defined assignments, and defined I/O procedures all perform callbacks into user code, which may well reenter the runtime library. This kind of recursion is not handled by this change, although it may be possible to do so in the future using thread-local work queues. (Relanding this patch after reverting initial attempt due to some test failures that needed some time to analyze and fix.) Fixes https://github.com/llvm/llvm-project/issues/142481.
627 lines
22 KiB
C++
627 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().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
|