[flang-commits] [flang] 43fadef - [flang] Implement user-defined derived type runtime I/O
peter klausler via flang-commits
flang-commits at lists.llvm.org
Mon Jun 28 11:36:30 PDT 2021
Author: peter klausler
Date: 2021-06-28T11:36:19-07:00
New Revision: 43fadefb0e77c56de7637c391cf98cf709b27095
URL: https://github.com/llvm/llvm-project/commit/43fadefb0e77c56de7637c391cf98cf709b27095
DIFF: https://github.com/llvm/llvm-project/commit/43fadefb0e77c56de7637c391cf98cf709b27095.diff
LOG: [flang] Implement user-defined derived type runtime I/O
With derived type description tables now available to the
runtime library, it is possible to implement the concept
of "child" I/O statements in the runtime and use them to
convert instances of derived type I/O data transfers into
calls to user-defined subroutines when they have been specified
for a type. (See Fortran 2018, subclauses 12.6.4.8 & 13.7.6).
- Support formatted, list-directed, and NAMELIST
transfers to internal parent units; support these, and unformatted
transfers, for external parent units.
- Support nested child defined derived type I/O.
- Parse DT'foo'(v-list) FORMAT data edit descriptors and passes
their strings &/or v-list values as arguments to the defined
formatted I/O routines.
- Fix problems with this feature encountered in semantics and
FORMAT valiation during development and end-to-end testing.
- Convert typeInfo::SpecialBinding from a struct to a class
after adding a member function.
Differential Revision: https://reviews.llvm.org/D104930
Added:
flang/runtime/descriptor-io.cpp
Modified:
flang/include/flang/Common/format.h
flang/lib/Semantics/check-declarations.cpp
flang/runtime/CMakeLists.txt
flang/runtime/derived.cpp
flang/runtime/descriptor-io.h
flang/runtime/format-implementation.h
flang/runtime/format.cpp
flang/runtime/format.h
flang/runtime/io-api.cpp
flang/runtime/io-error.cpp
flang/runtime/io-error.h
flang/runtime/io-stmt.cpp
flang/runtime/io-stmt.h
flang/runtime/tools.cpp
flang/runtime/type-info.cpp
flang/runtime/type-info.h
flang/runtime/unit-map.cpp
flang/runtime/unit.cpp
flang/runtime/unit.h
flang/test/Semantics/typeinfo01.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Common/format.h b/flang/include/flang/Common/format.h
index 99b8cbe41d7cf..e38ea6b0dfedf 100644
--- a/flang/include/flang/Common/format.h
+++ b/flang/include/flang/Common/format.h
@@ -136,11 +136,11 @@ template <typename CHAR = char> class FormatValidator {
const CHAR *cursor_{}; // current location in format_
const CHAR *laCursor_{}; // lookahead cursor
Token token_{}; // current token
+ TokenKind previousTokenKind_{TokenKind::None};
int64_t integerValue_{-1}; // value of UnsignedInteger token
Token knrToken_{}; // k, n, or r UnsignedInteger token
int64_t knrValue_{-1}; // -1 ==> not present
int64_t wValue_{-1};
- bool previousTokenWasInt_{false};
char argString_[3]{}; // 1-2 character msg arg; usually edit descriptor name
bool formatHasErrors_{false};
bool unterminatedFormatError_{false};
@@ -179,7 +179,7 @@ template <typename CHAR> void FormatValidator<CHAR>::NextToken() {
// At entry, cursor_ points before the start of the next token.
// At exit, cursor_ points to last CHAR of token_.
- previousTokenWasInt_ = token_.kind() == TokenKind::UnsignedInteger;
+ previousTokenKind_ = token_.kind();
CHAR c{NextChar()};
token_.set_kind(TokenKind::None);
token_.set_offset(cursor_ - format_);
@@ -416,7 +416,8 @@ template <typename CHAR> void FormatValidator<CHAR>::NextToken() {
}
}
SetLength();
- if (stmt_ == IoStmtKind::Read) { // 13.3.2p6
+ if (stmt_ == IoStmtKind::Read &&
+ previousTokenKind_ != TokenKind::DT) { // 13.3.2p6
ReportError("String edit descriptor in READ format expression");
} else if (token_.kind() != TokenKind::String) {
ReportError("Unterminated string");
@@ -829,7 +830,8 @@ template <typename CHAR> bool FormatValidator<CHAR>::Check() {
// Possible first token of the next format item; token not yet processed.
if (commaRequired) {
const char *s{"Expected ',' or ')' in format expression"}; // C1302
- if (previousTokenWasInt_ && itemsWithLeadingInts_.test(token_.kind())) {
+ if (previousTokenKind_ == TokenKind::UnsignedInteger &&
+ itemsWithLeadingInts_.test(token_.kind())) {
ReportError(s);
} else {
ReportWarning(s);
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 5d063f14499a3..b57d19b8a62e5 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1797,9 +1797,15 @@ void CheckHelper::CheckAlreadySeenDefinedIo(const DerivedTypeSpec *derivedType,
void CheckHelper::CheckDioDummyIsDerived(
const Symbol &subp, const Symbol &arg, GenericKind::DefinedIo ioKind) {
if (const DeclTypeSpec * type{arg.GetType()}) {
- const DerivedTypeSpec *derivedType{type->AsDerived()};
- if (derivedType) {
+ if (const DerivedTypeSpec * derivedType{type->AsDerived()}) {
CheckAlreadySeenDefinedIo(derivedType, ioKind, subp);
+ bool isPolymorphic{type->IsPolymorphic()};
+ if (isPolymorphic != IsExtensibleType(derivedType)) {
+ messages_.Say(arg.name(),
+ "Dummy argument '%s' of a defined input/output procedure must be %s when the derived type is %s"_err_en_US,
+ arg.name(), isPolymorphic ? "TYPE()" : "CLASS()",
+ isPolymorphic ? "not extensible" : "extensible");
+ }
} else {
messages_.Say(arg.name(),
"Dummy argument '%s' of a defined input/output procedure must have a"
diff --git a/flang/runtime/CMakeLists.txt b/flang/runtime/CMakeLists.txt
index 5f4bbc73c23d2..1f7e3d14728a4 100644
--- a/flang/runtime/CMakeLists.txt
+++ b/flang/runtime/CMakeLists.txt
@@ -40,6 +40,7 @@ add_flang_library(FortranRuntime
connection.cpp
derived.cpp
descriptor.cpp
+ descriptor-io.cpp
dot-product.cpp
edit-input.cpp
edit-output.cpp
diff --git a/flang/runtime/derived.cpp b/flang/runtime/derived.cpp
index ef4bddc8a4669..4875ef2a4bc57 100644
--- a/flang/runtime/derived.cpp
+++ b/flang/runtime/derived.cpp
@@ -20,9 +20,9 @@ static const typeInfo::SpecialBinding *FindFinal(
for (std::size_t j{0}; j < totalSpecialBindings; ++j) {
const auto &special{
*specialDesc.ZeroBasedIndexedElement<typeInfo::SpecialBinding>(j)};
- switch (special.which) {
+ switch (special.which()) {
case typeInfo::SpecialBinding::Which::Final:
- if (special.rank == rank) {
+ if (special.rank() == rank) {
return &special;
}
break;
@@ -40,20 +40,20 @@ static const typeInfo::SpecialBinding *FindFinal(
static void CallFinalSubroutine(
const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
if (const auto *special{FindFinal(derived, descriptor.rank())}) {
- if (special->which == typeInfo::SpecialBinding::Which::ElementalFinal) {
+ if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
std::size_t byteStride{descriptor.ElementBytes()};
- auto p{reinterpret_cast<void (*)(char *)>(special->proc)};
+ auto *p{special->GetProc<void (*)(char *)>()};
// Finalizable objects must be contiguous.
std::size_t elements{descriptor.Elements()};
for (std::size_t j{0}; j < elements; ++j) {
p(descriptor.OffsetElement<char>(j * byteStride));
}
- } else if (special->isArgDescriptorSet & 1) {
- auto p{reinterpret_cast<void (*)(const Descriptor &)>(special->proc)};
+ } else if (special->IsArgDescriptor(0)) {
+ auto *p{special->GetProc<void (*)(const Descriptor &)>()};
p(descriptor);
} else {
// Finalizable objects must be contiguous.
- auto p{reinterpret_cast<void (*)(char *)>(special->proc)};
+ auto *p{special->GetProc<void (*)(char *)>()};
p(descriptor.OffsetElement<char>());
}
}
diff --git a/flang/runtime/descriptor-io.cpp b/flang/runtime/descriptor-io.cpp
new file mode 100644
index 0000000000000..2e552b7c5228e
--- /dev/null
+++ b/flang/runtime/descriptor-io.cpp
@@ -0,0 +1,106 @@
+//===-- runtime/descriptor-io.cpp -----------------------------------------===//
+//
+// 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 "descriptor-io.h"
+
+namespace Fortran::runtime::io::descr {
+
+// User-defined derived type formatted I/O (maybe)
+std::optional<bool> DefinedFormattedIo(IoStatementState &io,
+ const Descriptor &descriptor, const typeInfo::SpecialBinding &special) {
+ std::optional<DataEdit> peek{io.GetNextDataEdit(0 /*to peek at it*/)};
+ if (peek &&
+ (peek->descriptor == DataEdit::DefinedDerivedType ||
+ peek->descriptor == DataEdit::ListDirected)) {
+ // User-defined derived type formatting
+ IoErrorHandler &handler{io.GetIoErrorHandler()};
+ DataEdit edit{*io.GetNextDataEdit()}; // consume it this time
+ RUNTIME_CHECK(handler, edit.descriptor == peek->descriptor);
+ char ioType[2 + edit.maxIoTypeChars];
+ auto ioTypeLen{std::size_t{2} /*"DT"*/ + edit.ioTypeChars};
+ if (edit.descriptor == DataEdit::DefinedDerivedType) {
+ ioType[0] = 'D';
+ ioType[1] = 'T';
+ std::memcpy(ioType + 2, edit.ioType, edit.ioTypeChars);
+ } else {
+ std::strcpy(
+ ioType, io.mutableModes().inNamelist ? "NAMELIST" : "LISTDIRECTED");
+ ioTypeLen = std::strlen(ioType);
+ }
+ StaticDescriptor<0, true> statDesc;
+ Descriptor &vListDesc{statDesc.descriptor()};
+ vListDesc.Establish(TypeCategory::Integer, sizeof(int), nullptr, 1);
+ vListDesc.set_base_addr(edit.vList);
+ vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
+ vListDesc.GetDimension(0).SetByteStride(
+ static_cast<SubscriptValue>(sizeof(int)));
+ ExternalFileUnit *actualExternal{io.GetExternalFileUnit()};
+ ExternalFileUnit *external{actualExternal};
+ if (!external) {
+ // Create a new unit to service defined I/O for an
+ // internal I/O parent.
+ external = &ExternalFileUnit::NewUnit(handler, true);
+ }
+ ChildIo &child{external->PushChildIo(io)};
+ int unit{external->unitNumber()};
+ int ioStat{IostatOk};
+ char ioMsg[100];
+ if (special.IsArgDescriptor(0)) {
+ auto *p{special.GetProc<void (*)(const Descriptor &, int &, char *,
+ const Descriptor &, int &, char *, std::size_t, std::size_t)>()};
+ p(descriptor, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
+ sizeof ioMsg);
+ } else {
+ auto *p{special.GetProc<void (*)(const void *, int &, char *,
+ const Descriptor &, int &, char *, std::size_t, std::size_t)>()};
+ p(descriptor.raw().base_addr, unit, ioType, vListDesc, ioStat, ioMsg,
+ ioTypeLen, sizeof ioMsg);
+ }
+ handler.Forward(ioStat, ioMsg, sizeof ioMsg);
+ external->PopChildIo(child);
+ if (!actualExternal) {
+ // Close unit created for internal I/O above.
+ auto *closing{external->LookUpForClose(external->unitNumber())};
+ RUNTIME_CHECK(handler, external == closing);
+ external->DestroyClosed();
+ }
+ return handler.GetIoStat() == IostatOk;
+ } else {
+ // There's a user-defined I/O subroutine, but there's a FORMAT present and
+ // it does not have a DT data edit descriptor, so apply default formatting
+ // to the components of the derived type as usual.
+ return std::nullopt;
+ }
+}
+
+// User-defined derived type unformatted I/O
+bool DefinedUnformattedIo(IoStatementState &io, const Descriptor &descriptor,
+ const typeInfo::SpecialBinding &special) {
+ // Unformatted I/O must have an external unit (or child thereof).
+ IoErrorHandler &handler{io.GetIoErrorHandler()};
+ ExternalFileUnit *external{io.GetExternalFileUnit()};
+ RUNTIME_CHECK(handler, external != nullptr);
+ ChildIo &child{external->PushChildIo(io)};
+ int unit{external->unitNumber()};
+ int ioStat{IostatOk};
+ char ioMsg[100];
+ if (special.IsArgDescriptor(0)) {
+ auto *p{special.GetProc<void (*)(
+ const Descriptor &, int &, int &, char *, std::size_t)>()};
+ p(descriptor, unit, ioStat, ioMsg, sizeof ioMsg);
+ } else {
+ auto *p{special.GetProc<void (*)(
+ const void *, int &, int &, char *, std::size_t)>()};
+ p(descriptor.raw().base_addr, unit, ioStat, ioMsg, sizeof ioMsg);
+ }
+ handler.Forward(ioStat, ioMsg, sizeof ioMsg);
+ external->PopChildIo(child);
+ return handler.GetIoStat() == IostatOk;
+}
+
+} // namespace Fortran::runtime::io::descr
diff --git a/flang/runtime/descriptor-io.h b/flang/runtime/descriptor-io.h
index 09d068612325b..2ebb449e46d11 100644
--- a/flang/runtime/descriptor-io.h
+++ b/flang/runtime/descriptor-io.h
@@ -10,6 +10,9 @@
#define FORTRAN_RUNTIME_DESCRIPTOR_IO_H_
// Implementation of I/O data list item transfers based on descriptors.
+// (All I/O items come through here so that the code is exercised for test;
+// some scalar I/O data transfer APIs could be changed to bypass their use
+// of descriptors in the future for better efficiency.)
#include "cpp-type.h"
#include "descriptor.h"
@@ -18,6 +21,7 @@
#include "io-stmt.h"
#include "terminator.h"
#include "type-info.h"
+#include "unit.h"
#include "flang/Common/uint128.h"
namespace Fortran::runtime::io::descr {
@@ -243,92 +247,130 @@ static bool DefaultFormattedComponentIO(IoStatementState &io,
}
}
+std::optional<bool> DefinedFormattedIo(
+ IoStatementState &, const Descriptor &, const typeInfo::SpecialBinding &);
+
template <Direction DIR>
static bool FormattedDerivedTypeIO(
IoStatementState &io, const Descriptor &descriptor) {
- Terminator &terminator{io.GetIoErrorHandler()};
+ IoErrorHandler &handler{io.GetIoErrorHandler()};
+ // Derived type information must be present for formatted I/O.
const DescriptorAddendum *addendum{descriptor.Addendum()};
- RUNTIME_CHECK(terminator, addendum != nullptr);
+ RUNTIME_CHECK(handler, addendum != nullptr);
const typeInfo::DerivedType *type{addendum->derivedType()};
- RUNTIME_CHECK(terminator, type != nullptr);
- if (false) {
- // TODO: user-defined derived type formatted I/O
- } else {
- // Default derived type formatting
- const Descriptor &compArray{type->component()};
- RUNTIME_CHECK(terminator, compArray.rank() == 1);
- std::size_t numComponents{compArray.Elements()};
- std::size_t numElements{descriptor.Elements()};
- SubscriptValue subscripts[maxRank];
- descriptor.GetLowerBounds(subscripts);
- for (std::size_t j{0}; j < numElements;
- ++j, descriptor.IncrementSubscripts(subscripts)) {
- SubscriptValue at[maxRank];
- compArray.GetLowerBounds(at);
- for (std::size_t k{0}; k < numComponents;
- ++k, compArray.IncrementSubscripts(at)) {
- const typeInfo::Component &component{
- *compArray.Element<typeInfo::Component>(at)};
- if (!DefaultFormattedComponentIO<DIR>(
- io, component, descriptor, subscripts, terminator)) {
- return false;
- }
+ RUNTIME_CHECK(handler, type != nullptr);
+ if (const typeInfo::SpecialBinding *
+ special{type->FindSpecialBinding(DIR == Direction::Input
+ ? typeInfo::SpecialBinding::Which::ReadFormatted
+ : typeInfo::SpecialBinding::Which::WriteFormatted)}) {
+ if (std::optional<bool> wasDefined{
+ DefinedFormattedIo(io, descriptor, *special)}) {
+ return *wasDefined; // user-defined I/O was applied
+ }
+ }
+ // Default componentwise derived type formatting
+ const Descriptor &compArray{type->component()};
+ RUNTIME_CHECK(handler, compArray.rank() == 1);
+ std::size_t numComponents{compArray.Elements()};
+ std::size_t numElements{descriptor.Elements()};
+ SubscriptValue subscripts[maxRank];
+ descriptor.GetLowerBounds(subscripts);
+ for (std::size_t j{0}; j < numElements;
+ ++j, descriptor.IncrementSubscripts(subscripts)) {
+ SubscriptValue at[maxRank];
+ compArray.GetLowerBounds(at);
+ for (std::size_t k{0}; k < numComponents;
+ ++k, compArray.IncrementSubscripts(at)) {
+ const typeInfo::Component &component{
+ *compArray.Element<typeInfo::Component>(at)};
+ if (!DefaultFormattedComponentIO<DIR>(
+ io, component, descriptor, subscripts, handler)) {
+ return false;
}
}
}
return true;
}
+bool DefinedUnformattedIo(
+ IoStatementState &, const Descriptor &, const typeInfo::SpecialBinding &);
+
+// Unformatted I/O
template <Direction DIR>
-static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
- if (!io.get_if<IoDirectionState<DIR>>()) {
- io.GetIoErrorHandler().Crash(
- "DescriptorIO() called for wrong I/O direction");
- return false;
- }
- if constexpr (DIR == Direction::Input) {
- if (!io.BeginReadingRecord()) {
- return false;
- }
- }
- if (auto *unf{io.get_if<UnformattedIoStatementState<DIR>>()}) {
+static bool UnformattedDescriptorIO(
+ IoStatementState &io, const Descriptor &descriptor) {
+ IoErrorHandler &handler{io.GetIoErrorHandler()};
+ const DescriptorAddendum *addendum{descriptor.Addendum()};
+ const typeInfo::DerivedType *type{
+ addendum ? addendum->derivedType() : nullptr};
+ if (const typeInfo::SpecialBinding *
+ special{type
+ ? type->FindSpecialBinding(DIR == Direction::Input
+ ? typeInfo::SpecialBinding::Which::ReadUnformatted
+ : typeInfo::SpecialBinding::Which::WriteUnformatted)
+ : nullptr}) {
+ // User-defined derived type unformatted I/O
+ return DefinedUnformattedIo(io, descriptor, *special);
+ } else {
+ // Regular derived type unformatted I/O, not user-defined
+ auto *externalUnf{io.get_if<ExternalUnformattedIoStatementState<DIR>>()};
+ auto *childUnf{io.get_if<ChildUnformattedIoStatementState<DIR>>()};
+ RUNTIME_CHECK(handler, externalUnf != nullptr || childUnf != nullptr);
std::size_t elementBytes{descriptor.ElementBytes()};
+ std::size_t numElements{descriptor.Elements()};
SubscriptValue subscripts[maxRank];
descriptor.GetLowerBounds(subscripts);
- std::size_t numElements{descriptor.Elements()};
- if (false) {
- // TODO: user-defined derived type unformatted I/O
- } else if (descriptor.IsContiguous()) { // contiguous unformatted I/O
- char &x{ExtractElement<char>(io, descriptor, subscripts)};
- auto totalBytes{numElements * elementBytes};
+ using CharType =
+ std::conditional_t<DIR == Direction::Output, const char, char>;
+ auto Transfer{[=](CharType &x, std::size_t totalBytes,
+ std::size_t elementBytes) -> bool {
if constexpr (DIR == Direction::Output) {
- return unf->Emit(&x, totalBytes, elementBytes);
+ return externalUnf ? externalUnf->Emit(&x, totalBytes, elementBytes)
+ : childUnf->Emit(&x, totalBytes, elementBytes);
} else {
- return unf->Receive(&x, totalBytes, elementBytes);
+ return externalUnf ? externalUnf->Receive(&x, totalBytes, elementBytes)
+ : childUnf->Receive(&x, totalBytes, elementBytes);
}
+ }};
+ if (descriptor.IsContiguous()) { // contiguous unformatted I/O
+ char &x{ExtractElement<char>(io, descriptor, subscripts)};
+ return Transfer(x, numElements * elementBytes, elementBytes);
} else { // non-contiguous unformatted I/O
for (std::size_t j{0}; j < numElements; ++j) {
char &x{ExtractElement<char>(io, descriptor, subscripts)};
- if constexpr (DIR == Direction::Output) {
- if (!unf->Emit(&x, elementBytes, elementBytes)) {
- return false;
- }
- } else {
- if (!unf->Receive(&x, elementBytes, elementBytes)) {
- return false;
- }
+ if (!Transfer(x, elementBytes, elementBytes)) {
+ return false;
}
if (!descriptor.IncrementSubscripts(subscripts) &&
j + 1 < numElements) {
- io.GetIoErrorHandler().Crash(
- "DescriptorIO: subscripts out of bounds");
+ handler.Crash("DescriptorIO: subscripts out of bounds");
}
}
return true;
}
- } else if (auto catAndKind{descriptor.type().GetCategoryAndKind()}) {
+ }
+}
+
+template <Direction DIR>
+static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
+ if (!io.get_if<IoDirectionState<DIR>>()) {
+ io.GetIoErrorHandler().Crash(
+ "DescriptorIO() called for wrong I/O direction");
+ return false;
+ }
+ if constexpr (DIR == Direction::Input) {
+ if (!io.BeginReadingRecord()) {
+ return false;
+ }
+ }
+ if (!io.get_if<FormattedIoStatementState>()) {
+ return UnformattedDescriptorIO<DIR>(io, descriptor);
+ }
+ IoErrorHandler &handler{io.GetIoErrorHandler()};
+ if (auto catAndKind{descriptor.type().GetCategoryAndKind()}) {
+ TypeCategory cat{catAndKind->first};
int kind{catAndKind->second};
- switch (catAndKind->first) {
+ switch (cat) {
case TypeCategory::Integer:
switch (kind) {
case 1:
@@ -347,7 +389,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
return FormattedIntegerIO<CppTypeFor<TypeCategory::Integer, 16>, DIR>(
io, descriptor);
default:
- io.GetIoErrorHandler().Crash(
+ handler.Crash(
"DescriptorIO: Unimplemented INTEGER kind (%d) in descriptor",
kind);
return false;
@@ -368,7 +410,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
case 16:
return FormattedRealIO<16, DIR>(io, descriptor);
default:
- io.GetIoErrorHandler().Crash(
+ handler.Crash(
"DescriptorIO: Unimplemented REAL kind (%d) in descriptor", kind);
return false;
}
@@ -388,7 +430,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
case 16:
return FormattedComplexIO<16, DIR>(io, descriptor);
default:
- io.GetIoErrorHandler().Crash(
+ handler.Crash(
"DescriptorIO: Unimplemented COMPLEX kind (%d) in descriptor",
kind);
return false;
@@ -399,7 +441,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
return FormattedCharacterIO<char, DIR>(io, descriptor);
// TODO cases 2, 4
default:
- io.GetIoErrorHandler().Crash(
+ handler.Crash(
"DescriptorIO: Unimplemented CHARACTER kind (%d) in descriptor",
kind);
return false;
@@ -419,7 +461,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
return FormattedLogicalIO<CppTypeFor<TypeCategory::Integer, 8>, DIR>(
io, descriptor);
default:
- io.GetIoErrorHandler().Crash(
+ handler.Crash(
"DescriptorIO: Unimplemented LOGICAL kind (%d) in descriptor",
kind);
return false;
@@ -428,7 +470,7 @@ static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
return FormattedDerivedTypeIO<DIR>(io, descriptor);
}
}
- io.GetIoErrorHandler().Crash("DescriptorIO: Bad type code (%d) in descriptor",
+ handler.Crash("DescriptorIO: Bad type code (%d) in descriptor",
static_cast<int>(descriptor.type().raw()));
return false;
}
diff --git a/flang/runtime/format-implementation.h b/flang/runtime/format-implementation.h
index 91d80a7336019..63ca682eb3e7a 100644
--- a/flang/runtime/format-implementation.h
+++ b/flang/runtime/format-implementation.h
@@ -338,10 +338,12 @@ int FormatControl<CONTEXT>::CueUpNextDataEdit(Context &context, bool stop) {
++offset_;
}
}
- if (ch == 'E' ||
- (!next &&
- (ch == 'A' || ch == 'I' || ch == 'B' || ch == 'O' || ch == 'Z' ||
- ch == 'F' || ch == 'D' || ch == 'G' || ch == 'L'))) {
+ if ((!next &&
+ (ch == 'A' || ch == 'I' || ch == 'B' || ch == 'E' || ch == 'D' ||
+ ch == 'O' || ch == 'Z' || ch == 'F' || ch == 'G' ||
+ ch == 'L')) ||
+ (ch == 'E' && (next == 'N' || next == 'S' || next == 'X')) ||
+ (ch == 'D' && next == 'T')) {
// Data edit descriptor found
offset_ = start;
return repeat && *repeat > 0 ? *repeat : 1;
@@ -363,34 +365,86 @@ int FormatControl<CONTEXT>::CueUpNextDataEdit(Context &context, bool stop) {
}
}
+// Returns the next data edit descriptor
template <typename CONTEXT>
DataEdit FormatControl<CONTEXT>::GetNextDataEdit(
Context &context, int maxRepeat) {
-
- // TODO: DT editing
-
- // Return the next data edit descriptor
int repeat{CueUpNextDataEdit(context)};
auto start{offset_};
DataEdit edit;
edit.descriptor = static_cast<char>(Capitalize(GetNextChar(context)));
if (edit.descriptor == 'E') {
- edit.variation = static_cast<char>(Capitalize(PeekNext()));
- if (edit.variation >= 'A' && edit.variation <= 'Z') {
+ if (auto next{static_cast<char>(Capitalize(PeekNext()))};
+ next == 'N' || next == 'S' || next == 'X') {
+ edit.variation = next;
++offset_;
}
+ } else if (edit.descriptor == 'D' && Capitalize(PeekNext()) == 'T') {
+ // DT'iotype'(v_list) user-defined derived type I/O
+ edit.descriptor = DataEdit::DefinedDerivedType;
+ ++offset_;
+ if (auto quote{static_cast<char>(PeekNext())};
+ quote == '\'' || quote == '"') {
+ // Capture the quoted 'iotype'
+ bool ok{false}, tooLong{false};
+ for (++offset_; offset_ < formatLength_;) {
+ auto ch{static_cast<char>(format_[offset_++])};
+ if (ch == quote &&
+ (offset_ == formatLength_ ||
+ static_cast<char>(format_[offset_]) != quote)) {
+ ok = true;
+ break; // that was terminating quote
+ } else if (edit.ioTypeChars >= edit.maxIoTypeChars) {
+ tooLong = true;
+ } else {
+ edit.ioType[edit.ioTypeChars++] = ch;
+ if (ch == quote) {
+ ++offset_;
+ }
+ }
+ }
+ if (!ok) {
+ context.SignalError(
+ IostatErrorInFormat, "Unclosed DT'iotype' in FORMAT");
+ } else if (tooLong) {
+ context.SignalError(
+ IostatErrorInFormat, "Excessive DT'iotype' in FORMAT");
+ }
+ }
+ if (PeekNext() == '(') {
+ // Capture the v_list arguments
+ bool ok{false}, tooLong{false};
+ for (++offset_; offset_ < formatLength_;) {
+ int n{GetIntField(context)};
+ if (edit.vListEntries >= edit.maxVListEntries) {
+ tooLong = true;
+ } else {
+ edit.vList[edit.vListEntries++] = n;
+ }
+ auto ch{static_cast<char>(GetNextChar(context))};
+ if (ch != ',') {
+ ok = ch == ')';
+ break;
+ }
+ }
+ if (!ok) {
+ context.SignalError(
+ IostatErrorInFormat, "Unclosed DT(v_list) in FORMAT");
+ } else if (tooLong) {
+ context.SignalError(
+ IostatErrorInFormat, "Excessive DT(v_list) in FORMAT");
+ }
+ }
}
-
if (edit.descriptor == 'A') { // width is optional for A[w]
auto ch{PeekNext()};
if (ch >= '0' && ch <= '9') {
edit.width = GetIntField(context);
}
- } else {
+ } else if (edit.descriptor != DataEdit::DefinedDerivedType) {
edit.width = GetIntField(context);
}
- edit.modes = context.mutableModes();
- if (PeekNext() == '.') {
+ if (edit.descriptor != DataEdit::DefinedDerivedType && PeekNext() == '.') {
++offset_;
edit.digits = GetIntField(context);
CharType ch{PeekNext()};
@@ -399,14 +453,15 @@ DataEdit FormatControl<CONTEXT>::GetNextDataEdit(
edit.expoDigits = GetIntField(context);
}
}
+ edit.modes = context.mutableModes();
// Handle repeated nonparenthesized edit descriptors
- if (repeat > 1) {
+ if (repeat > maxRepeat) {
stack_[height_].start = start; // after repeat count
stack_[height_].remaining = repeat; // full count
++height_;
}
- edit.repeat = 1;
+ edit.repeat = std::min(1, maxRepeat); // 0 if maxRepeat==0
if (height_ > 1) { // Subtle: stack_[0].start doesn't necessarily point to '('
int start{stack_[height_ - 1].start};
if (format_[start] != '(') {
diff --git a/flang/runtime/format.cpp b/flang/runtime/format.cpp
index 65ed12447bb58..e46cada81aa6c 100644
--- a/flang/runtime/format.cpp
+++ b/flang/runtime/format.cpp
@@ -9,50 +9,6 @@
#include "format-implementation.h"
namespace Fortran::runtime::io {
-
-DataEdit DefaultFormatControlCallbacks::GetNextDataEdit(int) {
- Crash("DefaultFormatControlCallbacks::GetNextDataEdit() called for "
- "non-formatted I/O statement");
- return {};
-}
-bool DefaultFormatControlCallbacks::Emit(
- const char *, std::size_t, std::size_t) {
- Crash("DefaultFormatControlCallbacks::Emit(char) called for non-output I/O "
- "statement");
- return {};
-}
-bool DefaultFormatControlCallbacks::Emit(const char16_t *, std::size_t) {
- Crash("DefaultFormatControlCallbacks::Emit(char16_t) called for non-output "
- "I/O statement");
- return {};
-}
-bool DefaultFormatControlCallbacks::Emit(const char32_t *, std::size_t) {
- Crash("DefaultFormatControlCallbacks::Emit(char32_t) called for non-output "
- "I/O statement");
- return {};
-}
-std::optional<char32_t> DefaultFormatControlCallbacks::GetCurrentChar() {
- Crash("DefaultFormatControlCallbacks::GetCurrentChar() called for non-input "
- "I/O "
- "statement");
- return {};
-}
-bool DefaultFormatControlCallbacks::AdvanceRecord(int) {
- Crash("DefaultFormatControlCallbacks::AdvanceRecord() called unexpectedly");
- return {};
-}
-void DefaultFormatControlCallbacks::BackspaceRecord() {
- Crash("DefaultFormatControlCallbacks::BackspaceRecord() called unexpectedly");
-}
-void DefaultFormatControlCallbacks::HandleAbsolutePosition(std::int64_t) {
- Crash("DefaultFormatControlCallbacks::HandleAbsolutePosition() called for "
- "non-formatted I/O statement");
-}
-void DefaultFormatControlCallbacks::HandleRelativePosition(std::int64_t) {
- Crash("DefaultFormatControlCallbacks::HandleRelativePosition() called for "
- "non-formatted I/O statement");
-}
-
template class FormatControl<
InternalFormattedIoStatementState<Direction::Output>>;
template class FormatControl<
@@ -61,4 +17,6 @@ template class FormatControl<
ExternalFormattedIoStatementState<Direction::Output>>;
template class FormatControl<
ExternalFormattedIoStatementState<Direction::Input>>;
+template class FormatControl<ChildFormattedIoStatementState<Direction::Output>>;
+template class FormatControl<ChildFormattedIoStatementState<Direction::Input>>;
} // namespace Fortran::runtime::io
diff --git a/flang/runtime/format.h b/flang/runtime/format.h
index 9dcd59a54a8bc..77daa38f3262e 100644
--- a/flang/runtime/format.h
+++ b/flang/runtime/format.h
@@ -51,32 +51,28 @@ struct DataEdit {
descriptor == ListDirectedImaginaryPart;
}
+ static constexpr char DefinedDerivedType{'d'}; // DT user-defined derived type
+
char variation{'\0'}; // N, S, or X for EN, ES, EX
std::optional<int> width; // the 'w' field; optional for A
std::optional<int> digits; // the 'm' or 'd' field
std::optional<int> expoDigits; // 'Ee' field
MutableModes modes;
int repeat{1};
-};
-// FormatControl<A> requires that A have these member functions;
-// these default implementations just crash if called.
-struct DefaultFormatControlCallbacks : public IoErrorHandler {
- using IoErrorHandler::IoErrorHandler;
- DataEdit GetNextDataEdit(int = 1);
- bool Emit(const char *, std::size_t, std::size_t elementBytes = 0);
- bool Emit(const char16_t *, std::size_t);
- bool Emit(const char32_t *, std::size_t);
- std::optional<char32_t> GetCurrentChar();
- bool AdvanceRecord(int = 1);
- void BackspaceRecord();
- void HandleAbsolutePosition(std::int64_t);
- void HandleRelativePosition(std::int64_t);
+ // "iotype" &/or "v_list" values for a DT'iotype'(v_list)
+ // user-defined derived type data edit descriptor
+ static constexpr std::size_t maxIoTypeChars{32};
+ static constexpr std::size_t maxVListEntries{4};
+ std::uint8_t ioTypeChars{0};
+ std::uint8_t vListEntries{0};
+ char ioType[maxIoTypeChars];
+ int vList[maxVListEntries];
};
// Generates a sequence of DataEdits from a FORMAT statement or
// default-CHARACTER string. Driven by I/O item list processing.
-// Errors are fatal. See clause 13.4 in Fortran 2018 for background.
+// Errors are fatal. See subclause 13.4 in Fortran 2018 for background.
template <typename CONTEXT> class FormatControl {
public:
using Context = CONTEXT;
@@ -98,7 +94,8 @@ template <typename CONTEXT> class FormatControl {
}
// Extracts the next data edit descriptor, handling control edit descriptors
- // along the way.
+ // along the way. If maxRepeat==0, this is a peek at the next data edit
+ // descriptor.
DataEdit GetNextDataEdit(Context &, int maxRepeat = 1);
// Emit any remaining character literals after the last data item (on output)
diff --git a/flang/runtime/io-api.cpp b/flang/runtime/io-api.cpp
index 8754cd666ae7a..d1b13cb330eba 100644
--- a/flang/runtime/io-api.cpp
+++ b/flang/runtime/io-api.cpp
@@ -156,22 +156,29 @@ Cookie BeginExternalListIO(const char *what, int unitNumber,
}
ExternalFileUnit &unit{ExternalFileUnit::LookUpOrCreateAnonymous(
unitNumber, DIR, false /*!unformatted*/, terminator)};
- if (unit.access == Access::Direct) {
- terminator.Crash("%s attempted on direct access file", what);
- return nullptr;
- }
- if (!unit.isUnformatted.has_value()) {
- unit.isUnformatted = false;
- }
- if (*unit.isUnformatted) {
- terminator.Crash("%s attempted on unformatted file", what);
- return nullptr;
+ if (ChildIo * child{unit.GetChildIo()}) {
+ return child->CheckFormattingAndDirection(terminator, what, false, DIR)
+ ? &child->BeginIoStatement<ChildListIoStatementState<DIR>>(
+ *child, sourceFile, sourceLine)
+ : nullptr;
+ } else {
+ if (unit.access == Access::Direct) {
+ terminator.Crash("%s attempted on direct access file", what);
+ return nullptr;
+ }
+ if (!unit.isUnformatted.has_value()) {
+ unit.isUnformatted = false;
+ }
+ if (*unit.isUnformatted) {
+ terminator.Crash("%s attempted on unformatted file", what);
+ return nullptr;
+ }
+ IoErrorHandler handler{terminator};
+ unit.SetDirection(DIR, handler);
+ IoStatementState &io{unit.BeginIoStatement<STATE<DIR>>(
+ std::forward<A>(xs)..., unit, sourceFile, sourceLine)};
+ return &io;
}
- IoErrorHandler handler{terminator};
- unit.SetDirection(DIR, handler);
- IoStatementState &io{unit.BeginIoStatement<STATE<DIR>>(
- std::forward<A>(xs)..., unit, sourceFile, sourceLine)};
- return &io;
}
Cookie IONAME(BeginExternalListOutput)(
@@ -195,19 +202,29 @@ Cookie BeginExternalFormattedIO(const char *format, std::size_t formatLength,
}
ExternalFileUnit &unit{ExternalFileUnit::LookUpOrCreateAnonymous(
unitNumber, DIR, false /*!unformatted*/, terminator)};
- if (!unit.isUnformatted.has_value()) {
- unit.isUnformatted = false;
- }
- if (*unit.isUnformatted) {
- terminator.Crash("Formatted I/O attempted on unformatted file");
- return nullptr;
+ if (ChildIo * child{unit.GetChildIo()}) {
+ return child->CheckFormattingAndDirection(terminator,
+ DIR == Direction::Output ? "formatted output"
+ : "formatted input",
+ false, DIR)
+ ? &child->BeginIoStatement<ChildFormattedIoStatementState<DIR>>(
+ *child, sourceFile, sourceLine)
+ : nullptr;
+ } else {
+ if (!unit.isUnformatted.has_value()) {
+ unit.isUnformatted = false;
+ }
+ if (*unit.isUnformatted) {
+ terminator.Crash("Formatted I/O attempted on unformatted file");
+ return nullptr;
+ }
+ IoErrorHandler handler{terminator};
+ unit.SetDirection(DIR, handler);
+ IoStatementState &io{
+ unit.BeginIoStatement<ExternalFormattedIoStatementState<DIR>>(
+ unit, format, formatLength, sourceFile, sourceLine)};
+ return &io;
}
- IoErrorHandler handler{terminator};
- unit.SetDirection(DIR, handler);
- IoStatementState &io{
- unit.BeginIoStatement<ExternalFormattedIoStatementState<DIR>>(
- unit, format, formatLength, sourceFile, sourceLine)};
- return &io;
}
Cookie IONAME(BeginExternalFormattedOutput)(const char *format,
@@ -230,25 +247,36 @@ Cookie BeginUnformattedIO(
Terminator terminator{sourceFile, sourceLine};
ExternalFileUnit &unit{ExternalFileUnit::LookUpOrCreateAnonymous(
unitNumber, DIR, true /*unformatted*/, terminator)};
- if (!unit.isUnformatted.has_value()) {
- unit.isUnformatted = true;
- }
- if (!*unit.isUnformatted) {
- terminator.Crash("Unformatted I/O attempted on formatted file");
- }
- IoStatementState &io{unit.BeginIoStatement<UnformattedIoStatementState<DIR>>(
- unit, sourceFile, sourceLine)};
- IoErrorHandler handler{terminator};
- unit.SetDirection(DIR, handler);
- if constexpr (DIR == Direction::Output) {
- if (unit.access == Access::Sequential && !unit.isFixedRecordLength) {
- // Create space for (sub)record header to be completed by
- // UnformattedIoStatementState<Direction::Output>::EndIoStatement()
- unit.recordLength.reset(); // in case of prior BACKSPACE
- io.Emit("\0\0\0\0", 4); // placeholder for record length header
+ if (ChildIo * child{unit.GetChildIo()}) {
+ return child->CheckFormattingAndDirection(terminator,
+ DIR == Direction::Output ? "unformatted output"
+ : "unformatted input",
+ true, DIR)
+ ? &child->BeginIoStatement<ChildUnformattedIoStatementState<DIR>>(
+ *child, sourceFile, sourceLine)
+ : nullptr;
+ } else {
+ if (!unit.isUnformatted.has_value()) {
+ unit.isUnformatted = true;
+ }
+ if (!*unit.isUnformatted) {
+ terminator.Crash("Unformatted I/O attempted on formatted file");
+ }
+ IoStatementState &io{
+ unit.BeginIoStatement<ExternalUnformattedIoStatementState<DIR>>(
+ unit, sourceFile, sourceLine)};
+ IoErrorHandler handler{terminator};
+ unit.SetDirection(DIR, handler);
+ if constexpr (DIR == Direction::Output) {
+ if (unit.access == Access::Sequential && !unit.isFixedRecordLength) {
+ // Create space for (sub)record header to be completed by
+ // ExternalUnformattedIoStatementState<Direction::Output>::EndIoStatement()
+ unit.recordLength.reset(); // in case of prior BACKSPACE
+ io.Emit("\0\0\0\0", 4); // placeholder for record length header
+ }
}
+ return &io;
}
- return &io;
}
Cookie IONAME(BeginUnformattedOutput)(
@@ -276,9 +304,7 @@ Cookie IONAME(BeginOpenUnit)( // OPEN(without NEWUNIT=)
Cookie IONAME(BeginOpenNewUnit)( // OPEN(NEWUNIT=j)
const char *sourceFile, int sourceLine) {
Terminator terminator{sourceFile, sourceLine};
- bool ignored{false};
- ExternalFileUnit &unit{ExternalFileUnit::LookUpOrCreate(
- ExternalFileUnit::NewUnit(terminator), terminator, ignored)};
+ ExternalFileUnit &unit{ExternalFileUnit::NewUnit(terminator)};
return &unit.BeginIoStatement<OpenStatementState>(
unit, false /*was an existing file*/, sourceFile, sourceLine);
}
@@ -895,7 +921,8 @@ bool IONAME(InputDescriptor)(Cookie cookie, const Descriptor &descriptor) {
bool IONAME(OutputUnformattedBlock)(Cookie cookie, const char *x,
std::size_t length, std::size_t elementBytes) {
IoStatementState &io{*cookie};
- if (auto *unf{io.get_if<UnformattedIoStatementState<Direction::Output>>()}) {
+ if (auto *unf{io.get_if<
+ ExternalUnformattedIoStatementState<Direction::Output>>()}) {
return unf->Emit(x, length, elementBytes);
}
io.GetIoErrorHandler().Crash("OutputUnformattedBlock() called for an I/O "
@@ -910,7 +937,8 @@ bool IONAME(InputUnformattedBlock)(
if (io.GetIoErrorHandler().InError()) {
return false;
}
- if (auto *unf{io.get_if<UnformattedIoStatementState<Direction::Input>>()}) {
+ if (auto *unf{
+ io.get_if<ExternalUnformattedIoStatementState<Direction::Input>>()}) {
return unf->Receive(x, length, elementBytes);
}
io.GetIoErrorHandler().Crash("InputUnformattedBlock() called for an I/O "
diff --git a/flang/runtime/io-error.cpp b/flang/runtime/io-error.cpp
index bc835bad1dc13..19342c5aa427b 100644
--- a/flang/runtime/io-error.cpp
+++ b/flang/runtime/io-error.cpp
@@ -57,6 +57,14 @@ void IoErrorHandler::SignalError(int iostatOrErrno) {
SignalError(iostatOrErrno, nullptr);
}
+void IoErrorHandler::Forward(
+ int ioStatOrErrno, const char *msg, std::size_t length) {
+ SignalError(ioStatOrErrno);
+ if (ioStat_ != IostatOk && (flags_ & hasIoMsg)) {
+ ioMsg_ = SaveDefaultCharacter(msg, length, *this);
+ }
+}
+
void IoErrorHandler::SignalErrno() { SignalError(errno); }
void IoErrorHandler::SignalEnd() { SignalError(IostatEnd); }
diff --git a/flang/runtime/io-error.h b/flang/runtime/io-error.h
index e51df9b5be866..dd2a269fef89a 100644
--- a/flang/runtime/io-error.h
+++ b/flang/runtime/io-error.h
@@ -32,6 +32,9 @@ class IoErrorHandler : public Terminator {
void HasEndLabel() { flags_ |= hasEnd; }
void HasEorLabel() { flags_ |= hasEor; }
void HasIoMsg() { flags_ |= hasIoMsg; }
+ void HandleAnything() {
+ flags_ = hasIoStat | hasErr | hasEnd | hasEor | hasIoMsg;
+ }
bool InError() const { return ioStat_ != IostatOk; }
@@ -41,6 +44,8 @@ class IoErrorHandler : public Terminator {
SignalError(IostatGenericError, msg, std::forward<X>(xs)...);
}
+ void Forward(int iostatOrErrno, const char *, std::size_t);
+
void SignalErrno(); // SignalError(errno)
void SignalEnd(); // input only; EOF on internal write is an error
void SignalEor(); // non-advancing input only; EOR on write is an error
diff --git a/flang/runtime/io-stmt.cpp b/flang/runtime/io-stmt.cpp
index 099d9038a8acd..3432f847cce51 100644
--- a/flang/runtime/io-stmt.cpp
+++ b/flang/runtime/io-stmt.cpp
@@ -21,32 +21,64 @@ namespace Fortran::runtime::io {
int IoStatementBase::EndIoStatement() { return GetIoStat(); }
+bool IoStatementBase::Emit(const char *, std::size_t, std::size_t) {
+ return false;
+}
+
+bool IoStatementBase::Emit(const char *, std::size_t) {
+ return false;
+}
+
+bool IoStatementBase::Emit(const char16_t *, std::size_t) {
+ return false;
+}
+
+bool IoStatementBase::Emit(const char32_t *, std::size_t) {
+ return false;
+}
+
+std::optional<char32_t> IoStatementBase::GetCurrentChar() {
+ return std::nullopt;
+}
+
+bool IoStatementBase::AdvanceRecord(int) { return false; }
+
+void IoStatementBase::BackspaceRecord() {}
+
+bool IoStatementBase::Receive(char *, std::size_t, std::size_t) {
+ return false;
+}
+
std::optional<DataEdit> IoStatementBase::GetNextDataEdit(
IoStatementState &, int) {
return std::nullopt;
}
+ExternalFileUnit *IoStatementBase::GetExternalFileUnit() const {
+ return nullptr;
+}
+
+bool IoStatementBase::BeginReadingRecord() { return true; }
+
+void IoStatementBase::FinishReadingRecord() {}
+
+void IoStatementBase::HandleAbsolutePosition(std::int64_t) {}
+
+void IoStatementBase::HandleRelativePosition(std::int64_t) {}
+
bool IoStatementBase::Inquire(InquiryKeywordHash, char *, std::size_t) {
- Crash(
- "IoStatementBase::Inquire() called for I/O statement other than INQUIRE");
return false;
}
bool IoStatementBase::Inquire(InquiryKeywordHash, bool &) {
- Crash(
- "IoStatementBase::Inquire() called for I/O statement other than INQUIRE");
return false;
}
bool IoStatementBase::Inquire(InquiryKeywordHash, std::int64_t, bool &) {
- Crash(
- "IoStatementBase::Inquire() called for I/O statement other than INQUIRE");
return false;
}
bool IoStatementBase::Inquire(InquiryKeywordHash, std::int64_t &) {
- Crash(
- "IoStatementBase::Inquire() called for I/O statement other than INQUIRE");
return false;
}
@@ -69,12 +101,12 @@ InternalIoStatementState<DIR, CHAR>::InternalIoStatementState(
template <Direction DIR, typename CHAR>
bool InternalIoStatementState<DIR, CHAR>::Emit(
- const CharType *data, std::size_t chars, std::size_t /*elementBytes*/) {
+ const CharType *data, std::size_t chars) {
if constexpr (DIR == Direction::Input) {
Crash("InternalIoStatementState<Direction::Input>::Emit() called");
return false;
}
- return unit_.Emit(data, chars, *this);
+ return unit_.Emit(data, chars * sizeof(CharType), *this);
}
template <Direction DIR, typename CHAR>
@@ -252,6 +284,14 @@ bool ExternalIoStatementState<DIR>::Emit(
return unit().Emit(data, bytes, elementBytes, *this);
}
+template <Direction DIR>
+bool ExternalIoStatementState<DIR>::Emit(const char *data, std::size_t bytes) {
+ if constexpr (DIR == Direction::Input) {
+ Crash("ExternalIoStatementState::Emit(char) called for input statement");
+ }
+ return unit().Emit(data, bytes, 0, *this);
+}
+
template <Direction DIR>
bool ExternalIoStatementState<DIR>::Emit(
const char16_t *data, std::size_t chars) {
@@ -261,7 +301,7 @@ bool ExternalIoStatementState<DIR>::Emit(
}
// TODO: UTF-8 encoding
return unit().Emit(reinterpret_cast<const char *>(data), chars * sizeof *data,
- static_cast<int>(sizeof *data), *this);
+ sizeof *data, *this);
}
template <Direction DIR>
@@ -273,7 +313,7 @@ bool ExternalIoStatementState<DIR>::Emit(
}
// TODO: UTF-8 encoding
return unit().Emit(reinterpret_cast<const char *>(data), chars * sizeof *data,
- static_cast<int>(sizeof *data), *this);
+ sizeof *data, *this);
}
template <Direction DIR>
@@ -354,6 +394,24 @@ bool IoStatementState::Emit(
[=](auto &x) { return x.get().Emit(data, n, elementBytes); }, u_);
}
+bool IoStatementState::Emit(const char *data, std::size_t n) {
+ return std::visit([=](auto &x) { return x.get().Emit(data, n); }, u_);
+}
+
+bool IoStatementState::Emit(const char16_t *data, std::size_t chars) {
+ return std::visit([=](auto &x) { return x.get().Emit(data, chars); }, u_);
+}
+
+bool IoStatementState::Emit(const char32_t *data, std::size_t chars) {
+ return std::visit([=](auto &x) { return x.get().Emit(data, chars); }, u_);
+}
+
+bool IoStatementState::Receive(
+ char *data, std::size_t n, std::size_t elementBytes) {
+ return std::visit(
+ [=](auto &x) { return x.get().Receive(data, n, elementBytes); }, u_);
+}
+
std::optional<char32_t> IoStatementState::GetCurrentChar() {
return std::visit([&](auto &x) { return x.get().GetCurrentChar(); }, u_);
}
@@ -370,6 +428,10 @@ void IoStatementState::HandleRelativePosition(std::int64_t n) {
std::visit([=](auto &x) { x.get().HandleRelativePosition(n); }, u_);
}
+void IoStatementState::HandleAbsolutePosition(std::int64_t n) {
+ std::visit([=](auto &x) { x.get().HandleAbsolutePosition(n); }, u_);
+}
+
int IoStatementState::EndIoStatement() {
return std::visit([](auto &x) { return x.get().EndIoStatement(); }, u_);
}
@@ -682,23 +744,100 @@ ListDirectedStatementState<Direction::Input>::GetNextDataEdit(
}
template <Direction DIR>
-bool UnformattedIoStatementState<DIR>::Receive(
+bool ExternalUnformattedIoStatementState<DIR>::Receive(
char *data, std::size_t bytes, std::size_t elementBytes) {
if constexpr (DIR == Direction::Output) {
- this->Crash(
- "UnformattedIoStatementState::Receive() called for output statement");
+ this->Crash("ExternalUnformattedIoStatementState::Receive() called for "
+ "output statement");
}
return this->unit().Receive(data, bytes, elementBytes, *this);
}
template <Direction DIR>
-bool UnformattedIoStatementState<DIR>::Emit(
+ChildIoStatementState<DIR>::ChildIoStatementState(
+ ChildIo &child, const char *sourceFile, int sourceLine)
+ : IoStatementBase{sourceFile, sourceLine}, child_{child} {}
+
+template <Direction DIR>
+MutableModes &ChildIoStatementState<DIR>::mutableModes() {
+ return child_.parent().mutableModes();
+}
+
+template <Direction DIR>
+ConnectionState &ChildIoStatementState<DIR>::GetConnectionState() {
+ return child_.parent().GetConnectionState();
+}
+
+template <Direction DIR>
+ExternalFileUnit *ChildIoStatementState<DIR>::GetExternalFileUnit() const {
+ return child_.parent().GetExternalFileUnit();
+}
+
+template <Direction DIR> int ChildIoStatementState<DIR>::EndIoStatement() {
+ auto result{IoStatementBase::EndIoStatement()};
+ child_.EndIoStatement(); // annihilates *this in child_.u_
+ return result;
+}
+
+template <Direction DIR>
+bool ChildIoStatementState<DIR>::Emit(
const char *data, std::size_t bytes, std::size_t elementBytes) {
- if constexpr (DIR == Direction::Input) {
- this->Crash(
- "UnformattedIoStatementState::Emit() called for input statement");
- }
- return ExternalIoStatementState<DIR>::Emit(data, bytes, elementBytes);
+ return child_.parent().Emit(data, bytes, elementBytes);
+}
+
+template <Direction DIR>
+bool ChildIoStatementState<DIR>::Emit(const char *data, std::size_t bytes) {
+ return child_.parent().Emit(data, bytes);
+}
+
+template <Direction DIR>
+bool ChildIoStatementState<DIR>::Emit(const char16_t *data, std::size_t chars) {
+ return child_.parent().Emit(data, chars);
+}
+
+template <Direction DIR>
+bool ChildIoStatementState<DIR>::Emit(const char32_t *data, std::size_t chars) {
+ return child_.parent().Emit(data, chars);
+}
+
+template <Direction DIR>
+std::optional<char32_t> ChildIoStatementState<DIR>::GetCurrentChar() {
+ return child_.parent().GetCurrentChar();
+}
+
+template <Direction DIR>
+void ChildIoStatementState<DIR>::HandleAbsolutePosition(std::int64_t n) {
+ return child_.parent().HandleAbsolutePosition(n);
+}
+
+template <Direction DIR>
+void ChildIoStatementState<DIR>::HandleRelativePosition(std::int64_t n) {
+ return child_.parent().HandleRelativePosition(n);
+}
+
+template <Direction DIR, typename CHAR>
+ChildFormattedIoStatementState<DIR, CHAR>::ChildFormattedIoStatementState(
+ ChildIo &child, const CHAR *format, std::size_t formatLength,
+ const char *sourceFile, int sourceLine)
+ : ChildIoStatementState<DIR>{child, sourceFile, sourceLine},
+ mutableModes_{child.parent().mutableModes()}, format_{*this, format,
+ formatLength} {}
+
+template <Direction DIR, typename CHAR>
+int ChildFormattedIoStatementState<DIR, CHAR>::EndIoStatement() {
+ format_.Finish(*this);
+ return ChildIoStatementState<DIR>::EndIoStatement();
+}
+
+template <Direction DIR, typename CHAR>
+bool ChildFormattedIoStatementState<DIR, CHAR>::AdvanceRecord(int) {
+ return false; // no can do in a child I/O
+}
+
+template <Direction DIR>
+bool ChildUnformattedIoStatementState<DIR>::Receive(
+ char *data, std::size_t bytes, std::size_t elementBytes) {
+ return this->child().parent().Receive(data, bytes, elementBytes);
}
template class InternalIoStatementState<Direction::Output>;
@@ -713,8 +852,16 @@ template class ExternalFormattedIoStatementState<Direction::Output>;
template class ExternalFormattedIoStatementState<Direction::Input>;
template class ExternalListIoStatementState<Direction::Output>;
template class ExternalListIoStatementState<Direction::Input>;
-template class UnformattedIoStatementState<Direction::Output>;
-template class UnformattedIoStatementState<Direction::Input>;
+template class ExternalUnformattedIoStatementState<Direction::Output>;
+template class ExternalUnformattedIoStatementState<Direction::Input>;
+template class ChildIoStatementState<Direction::Output>;
+template class ChildIoStatementState<Direction::Input>;
+template class ChildFormattedIoStatementState<Direction::Output>;
+template class ChildFormattedIoStatementState<Direction::Input>;
+template class ChildListIoStatementState<Direction::Output>;
+template class ChildListIoStatementState<Direction::Input>;
+template class ChildUnformattedIoStatementState<Direction::Output>;
+template class ChildUnformattedIoStatementState<Direction::Input>;
int ExternalMiscIoStatementState::EndIoStatement() {
ExternalFileUnit &ext{unit()};
@@ -742,6 +889,12 @@ InquireUnitState::InquireUnitState(
bool InquireUnitState::Inquire(
InquiryKeywordHash inquiry, char *result, std::size_t length) {
+ if (unit().createdForInternalChildIo()) {
+ SignalError(IostatInquireInternalUnit,
+ "INQUIRE of unit created for defined derived type I/O of an internal "
+ "unit");
+ return false;
+ }
const char *str{nullptr};
switch (inquiry) {
case HashInquiryKeyword("ACCESS"):
@@ -1161,10 +1314,4 @@ InquireIOLengthState::InquireIOLengthState(
const char *sourceFile, int sourceLine)
: NoUnitIoStatementState{sourceFile, sourceLine, *this} {}
-bool InquireIOLengthState::Emit(
- const char *, std::size_t n, std::size_t /*elementBytes*/) {
- bytes_ += n;
- return true;
-}
-
} // namespace Fortran::runtime::io
diff --git a/flang/runtime/io-stmt.h b/flang/runtime/io-stmt.h
index b76c5202619b7..34c4a47363c0d 100644
--- a/flang/runtime/io-stmt.h
+++ b/flang/runtime/io-stmt.h
@@ -25,6 +25,7 @@
namespace Fortran::runtime::io {
class ExternalFileUnit;
+class ChildIo;
class OpenStatementState;
class InquireUnitState;
@@ -41,7 +42,10 @@ template <Direction, typename CHAR = char> class InternalListIoStatementState;
template <Direction, typename CHAR = char>
class ExternalFormattedIoStatementState;
template <Direction> class ExternalListIoStatementState;
-template <Direction> class UnformattedIoStatementState;
+template <Direction> class ExternalUnformattedIoStatementState;
+template <Direction, typename CHAR = char> class ChildFormattedIoStatementState;
+template <Direction> class ChildListIoStatementState;
+template <Direction> class ChildUnformattedIoStatementState;
struct InputStatementState {};
struct OutputStatementState {};
@@ -60,17 +64,19 @@ class IoStatementState {
// to interact with the state of the I/O statement in progress.
// This design avoids virtual member functions and function pointers,
// which may not have good support in some runtime environments.
- std::optional<DataEdit> GetNextDataEdit(int = 1);
- bool Emit(const char *, std::size_t, std::size_t elementBytes = 0);
+ int EndIoStatement();
+ bool Emit(const char *, std::size_t, std::size_t elementBytes);
+ bool Emit(const char *, std::size_t);
+ bool Emit(const char16_t *, std::size_t chars);
+ bool Emit(const char32_t *, std::size_t chars);
+ bool Receive(char *, std::size_t, std::size_t elementBytes = 0);
std::optional<char32_t> GetCurrentChar(); // vacant after end of record
bool AdvanceRecord(int = 1);
void BackspaceRecord();
void HandleRelativePosition(std::int64_t);
- int EndIoStatement();
- ConnectionState &GetConnectionState();
- IoErrorHandler &GetIoErrorHandler() const;
+ void HandleAbsolutePosition(std::int64_t); // for r* in list I/O
+ std::optional<DataEdit> GetNextDataEdit(int = 1);
ExternalFileUnit *GetExternalFileUnit() const; // null if internal unit
- MutableModes &mutableModes();
bool BeginReadingRecord();
void FinishReadingRecord();
bool Inquire(InquiryKeywordHash, char *, std::size_t);
@@ -78,6 +84,10 @@ class IoStatementState {
bool Inquire(InquiryKeywordHash, std::int64_t, bool &); // PENDING=
bool Inquire(InquiryKeywordHash, std::int64_t &);
+ MutableModes &mutableModes();
+ ConnectionState &GetConnectionState();
+ IoErrorHandler &GetIoErrorHandler() const;
+
// N.B.: this also works with base classes
template <typename A> A *get_if() const {
return std::visit(
@@ -129,8 +139,18 @@ class IoStatementState {
ExternalFormattedIoStatementState<Direction::Input>>,
std::reference_wrapper<ExternalListIoStatementState<Direction::Output>>,
std::reference_wrapper<ExternalListIoStatementState<Direction::Input>>,
- std::reference_wrapper<UnformattedIoStatementState<Direction::Output>>,
- std::reference_wrapper<UnformattedIoStatementState<Direction::Input>>,
+ std::reference_wrapper<
+ ExternalUnformattedIoStatementState<Direction::Output>>,
+ std::reference_wrapper<
+ ExternalUnformattedIoStatementState<Direction::Input>>,
+ std::reference_wrapper<ChildFormattedIoStatementState<Direction::Output>>,
+ std::reference_wrapper<ChildFormattedIoStatementState<Direction::Input>>,
+ std::reference_wrapper<ChildListIoStatementState<Direction::Output>>,
+ std::reference_wrapper<ChildListIoStatementState<Direction::Input>>,
+ std::reference_wrapper<
+ ChildUnformattedIoStatementState<Direction::Output>>,
+ std::reference_wrapper<
+ ChildUnformattedIoStatementState<Direction::Input>>,
std::reference_wrapper<InquireUnitState>,
std::reference_wrapper<InquireNoUnitState>,
std::reference_wrapper<InquireUnconnectedFileState>,
@@ -140,18 +160,30 @@ class IoStatementState {
};
// Base class for all per-I/O statement state classes.
-// Inherits IoErrorHandler from its base.
-struct IoStatementBase : public DefaultFormatControlCallbacks {
- using DefaultFormatControlCallbacks::DefaultFormatControlCallbacks;
+struct IoStatementBase : public IoErrorHandler {
+ using IoErrorHandler::IoErrorHandler;
+
+ // These are default no-op backstops that can be overridden by descendants.
int EndIoStatement();
+ bool Emit(const char *, std::size_t, std::size_t elementBytes);
+ bool Emit(const char *, std::size_t);
+ bool Emit(const char16_t *, std::size_t chars);
+ bool Emit(const char32_t *, std::size_t chars);
+ bool Receive(char *, std::size_t, std::size_t elementBytes = 0);
+ std::optional<char32_t> GetCurrentChar();
+ bool AdvanceRecord(int);
+ void BackspaceRecord();
+ void HandleRelativePosition(std::int64_t);
+ void HandleAbsolutePosition(std::int64_t);
std::optional<DataEdit> GetNextDataEdit(IoStatementState &, int = 1);
- ExternalFileUnit *GetExternalFileUnit() const { return nullptr; }
- bool BeginReadingRecord() { return true; }
- void FinishReadingRecord() {}
+ ExternalFileUnit *GetExternalFileUnit() const;
+ bool BeginReadingRecord();
+ void FinishReadingRecord();
bool Inquire(InquiryKeywordHash, char *, std::size_t);
bool Inquire(InquiryKeywordHash, bool &);
bool Inquire(InquiryKeywordHash, std::int64_t, bool &);
bool Inquire(InquiryKeywordHash, std::int64_t &);
+
void BadInquiryKeywordHashCrash(InquiryKeywordHash);
};
@@ -207,8 +239,11 @@ class InternalIoStatementState : public IoStatementBase,
InternalIoStatementState(
const Descriptor &, const char *sourceFile = nullptr, int sourceLine = 0);
int EndIoStatement();
- bool Emit(const CharType *, std::size_t chars /* not necessarily bytes */,
- std::size_t elementBytes = 0);
+
+ using IoStatementBase::Emit;
+ bool Emit(
+ const CharType *data, std::size_t chars /* not necessarily bytes */);
+
std::optional<char32_t> GetCurrentChar();
bool AdvanceRecord(int = 1);
void BackspaceRecord();
@@ -275,7 +310,7 @@ class ExternalIoStatementBase : public IoStatementBase {
MutableModes &mutableModes();
ConnectionState &GetConnectionState();
int EndIoStatement();
- ExternalFileUnit *GetExternalFileUnit() { return &unit_; }
+ ExternalFileUnit *GetExternalFileUnit() const { return &unit_; }
private:
ExternalFileUnit &unit_;
@@ -287,7 +322,8 @@ class ExternalIoStatementState : public ExternalIoStatementBase,
public:
using ExternalIoStatementBase::ExternalIoStatementBase;
int EndIoStatement();
- bool Emit(const char *, std::size_t, std::size_t elementBytes = 0);
+ bool Emit(const char *, std::size_t, std::size_t elementBytes);
+ bool Emit(const char *, std::size_t);
bool Emit(const char16_t *, std::size_t chars /* not bytes */);
bool Emit(const char32_t *, std::size_t chars /* not bytes */);
std::optional<char32_t> GetCurrentChar();
@@ -331,13 +367,73 @@ class ExternalListIoStatementState : public ExternalIoStatementState<DIR>,
};
template <Direction DIR>
-class UnformattedIoStatementState : public ExternalIoStatementState<DIR> {
+class ExternalUnformattedIoStatementState
+ : public ExternalIoStatementState<DIR> {
public:
using ExternalIoStatementState<DIR>::ExternalIoStatementState;
bool Receive(char *, std::size_t, std::size_t elementBytes = 0);
- bool Emit(const char *, std::size_t, std::size_t elementBytes = 0);
};
+template <Direction DIR>
+class ChildIoStatementState : public IoStatementBase,
+ public IoDirectionState<DIR> {
+public:
+ ChildIoStatementState(
+ ChildIo &, const char *sourceFile = nullptr, int sourceLine = 0);
+ ChildIo &child() { return child_; }
+ MutableModes &mutableModes();
+ ConnectionState &GetConnectionState();
+ ExternalFileUnit *GetExternalFileUnit() const;
+ int EndIoStatement();
+ bool Emit(const char *, std::size_t, std::size_t elementBytes);
+ bool Emit(const char *, std::size_t);
+ bool Emit(const char16_t *, std::size_t chars /* not bytes */);
+ bool Emit(const char32_t *, std::size_t chars /* not bytes */);
+ std::optional<char32_t> GetCurrentChar();
+ void HandleRelativePosition(std::int64_t);
+ void HandleAbsolutePosition(std::int64_t);
+
+private:
+ ChildIo &child_;
+};
+
+template <Direction DIR, typename CHAR>
+class ChildFormattedIoStatementState : public ChildIoStatementState<DIR>,
+ public FormattedIoStatementState {
+public:
+ using CharType = CHAR;
+ ChildFormattedIoStatementState(ChildIo &, const CharType *format,
+ std::size_t formatLength, const char *sourceFile = nullptr,
+ int sourceLine = 0);
+ MutableModes &mutableModes() { return mutableModes_; }
+ int EndIoStatement();
+ bool AdvanceRecord(int = 1);
+ std::optional<DataEdit> GetNextDataEdit(
+ IoStatementState &, int maxRepeat = 1) {
+ return format_.GetNextDataEdit(*this, maxRepeat);
+ }
+
+private:
+ MutableModes mutableModes_;
+ FormatControl<ChildFormattedIoStatementState> format_;
+};
+
+template <Direction DIR>
+class ChildListIoStatementState : public ChildIoStatementState<DIR>,
+ public ListDirectedStatementState<DIR> {
+public:
+ using ChildIoStatementState<DIR>::ChildIoStatementState;
+ using ListDirectedStatementState<DIR>::GetNextDataEdit;
+};
+
+template <Direction DIR>
+class ChildUnformattedIoStatementState : public ChildIoStatementState<DIR> {
+public:
+ using ChildIoStatementState<DIR>::ChildIoStatementState;
+ bool Receive(char *, std::size_t, std::size_t elementBytes = 0);
+};
+
+// OPEN
class OpenStatementState : public ExternalIoStatementBase {
public:
OpenStatementState(ExternalFileUnit &unit, bool wasExtant,
@@ -415,8 +511,17 @@ extern template class ExternalFormattedIoStatementState<Direction::Output>;
extern template class ExternalFormattedIoStatementState<Direction::Input>;
extern template class ExternalListIoStatementState<Direction::Output>;
extern template class ExternalListIoStatementState<Direction::Input>;
-extern template class UnformattedIoStatementState<Direction::Output>;
-extern template class UnformattedIoStatementState<Direction::Input>;
+extern template class ExternalUnformattedIoStatementState<Direction::Output>;
+extern template class ExternalUnformattedIoStatementState<Direction::Input>;
+extern template class ChildIoStatementState<Direction::Output>;
+extern template class ChildIoStatementState<Direction::Input>;
+extern template class ChildFormattedIoStatementState<Direction::Output>;
+extern template class ChildFormattedIoStatementState<Direction::Input>;
+extern template class ChildListIoStatementState<Direction::Output>;
+extern template class ChildListIoStatementState<Direction::Input>;
+extern template class ChildUnformattedIoStatementState<Direction::Output>;
+extern template class ChildUnformattedIoStatementState<Direction::Input>;
+
extern template class FormatControl<
InternalFormattedIoStatementState<Direction::Output>>;
extern template class FormatControl<
@@ -425,6 +530,10 @@ extern template class FormatControl<
ExternalFormattedIoStatementState<Direction::Output>>;
extern template class FormatControl<
ExternalFormattedIoStatementState<Direction::Input>>;
+extern template class FormatControl<
+ ChildFormattedIoStatementState<Direction::Output>>;
+extern template class FormatControl<
+ ChildFormattedIoStatementState<Direction::Input>>;
class InquireUnitState : public ExternalIoStatementBase {
public:
@@ -463,7 +572,6 @@ class InquireIOLengthState : public NoUnitIoStatementState,
public:
InquireIOLengthState(const char *sourceFile = nullptr, int sourceLine = 0);
std::size_t bytes() const { return bytes_; }
- bool Emit(const char *, std::size_t, std::size_t elementBytes = 0);
private:
std::size_t bytes_{0};
diff --git a/flang/runtime/tools.cpp b/flang/runtime/tools.cpp
index c67da77e0c118..07f38cdf3efa5 100644
--- a/flang/runtime/tools.cpp
+++ b/flang/runtime/tools.cpp
@@ -71,9 +71,11 @@ int IdentifyValue(
void ToFortranDefaultCharacter(
char *to, std::size_t toLength, const char *from) {
std::size_t len{std::strlen(from)};
- std::memcpy(to, from, std::max(toLength, len));
if (len < toLength) {
+ std::memcpy(to, from, len);
std::memset(to + len, ' ', toLength - len);
+ } else {
+ std::memcpy(to, from, toLength);
}
}
diff --git a/flang/runtime/type-info.cpp b/flang/runtime/type-info.cpp
index df72fc466a29b..9385eabf2dc84 100644
--- a/flang/runtime/type-info.cpp
+++ b/flang/runtime/type-info.cpp
@@ -82,6 +82,21 @@ const Component *DerivedType::FindDataComponent(
: nullptr;
}
+const SpecialBinding *DerivedType::FindSpecialBinding(
+ SpecialBinding::Which which) const {
+ const Descriptor &specialDesc{special()};
+ std::size_t n{specialDesc.Elements()};
+ SubscriptValue at[maxRank];
+ specialDesc.GetLowerBounds(at);
+ for (std::size_t j{0}; j < n; ++j, specialDesc.IncrementSubscripts(at)) {
+ const SpecialBinding &special{*specialDesc.Element<SpecialBinding>(at)};
+ if (special.which() == which) {
+ return &special;
+ }
+ }
+ return nullptr;
+}
+
static void DumpScalarCharacter(
FILE *f, const Descriptor &desc, const char *what) {
if (desc.raw().version == CFI_VERSION &&
@@ -103,7 +118,7 @@ FILE *DerivedType::Dump(FILE *f) const {
int offset{j * static_cast<int>(sizeof *uints)};
std::fprintf(f, " [+%3d](0x%p) %#016jx", offset,
reinterpret_cast<const void *>(&uints[j]),
- static_cast<std::intmax_t>(uints[j]));
+ static_cast<std::uintmax_t>(uints[j]));
if (offset == offsetof(DerivedType, binding_)) {
std::fputs(" <-- binding_\n", f);
} else if (offset == offsetof(DerivedType, name_)) {
@@ -151,6 +166,15 @@ FILE *DerivedType::Dump(FILE *f) const {
std::fputs(" bad descriptor: ", f);
compDesc.Dump(f);
}
+ const Descriptor &specialDesc{special()};
+ std::fprintf(
+ f, "\n special descriptor (byteSize 0x%zx): ", special_.byteSize);
+ specialDesc.Dump(f);
+ std::size_t specials{specialDesc.Elements()};
+ for (std::size_t j{0}; j < specials; ++j) {
+ std::fprintf(f, " [%3zd] ", j);
+ specialDesc.ZeroBasedIndexedElement<SpecialBinding>(j)->Dump(f);
+ }
return f;
}
@@ -174,4 +198,46 @@ FILE *Component::Dump(FILE *f) const {
return f;
}
+FILE *SpecialBinding::Dump(FILE *f) const {
+ std::fprintf(
+ f, "SpecialBinding @ 0x%p:\n", reinterpret_cast<const void *>(this));
+ switch (which_) {
+ case Which::Assignment:
+ std::fputs(" Assignment", f);
+ break;
+ case Which::ElementalAssignment:
+ std::fputs(" ElementalAssignment", f);
+ break;
+ case Which::Final:
+ std::fputs(" Final", f);
+ break;
+ case Which::ElementalFinal:
+ std::fputs(" ElementalFinal", f);
+ break;
+ case Which::AssumedRankFinal:
+ std::fputs(" AssumedRankFinal", f);
+ break;
+ case Which::ReadFormatted:
+ std::fputs(" ReadFormatted", f);
+ break;
+ case Which::ReadUnformatted:
+ std::fputs(" ReadUnformatted", f);
+ break;
+ case Which::WriteFormatted:
+ std::fputs(" WriteFormatted", f);
+ break;
+ case Which::WriteUnformatted:
+ std::fputs(" WriteUnformatted", f);
+ break;
+ default:
+ std::fprintf(
+ f, " Unknown which: 0x%x", static_cast<std::uint8_t>(which_));
+ break;
+ }
+ std::fprintf(f, "\n rank: %d\n", rank_);
+ std::fprintf(f, " isArgDescriptoSetr: 0x%x\n", isArgDescriptorSet_);
+ std::fprintf(f, " proc: 0x%p\n", reinterpret_cast<void *>(proc_));
+ return f;
+}
+
} // namespace Fortran::runtime::typeInfo
diff --git a/flang/runtime/type-info.h b/flang/runtime/type-info.h
index 05a4c41a34997..0dfb4b64ffd35 100644
--- a/flang/runtime/type-info.h
+++ b/flang/runtime/type-info.h
@@ -20,81 +20,7 @@
namespace Fortran::runtime::typeInfo {
-class Component;
-
-class DerivedType {
-public:
- ~DerivedType(); // never defined
-
- const Descriptor &binding() const { return binding_.descriptor(); }
- const Descriptor &name() const { return name_.descriptor(); }
- std::uint64_t sizeInBytes() const { return sizeInBytes_; }
- const Descriptor &parent() const { return parent_.descriptor(); }
- std::uint64_t typeHash() const { return typeHash_; }
- const Descriptor &uninstatiated() const {
- return uninstantiated_.descriptor();
- }
- const Descriptor &kindParameter() const {
- return kindParameter_.descriptor();
- }
- const Descriptor &lenParameterKind() const {
- return lenParameterKind_.descriptor();
- }
- const Descriptor &component() const { return component_.descriptor(); }
- const Descriptor &procPtr() const { return procPtr_.descriptor(); }
- const Descriptor &special() const { return special_.descriptor(); }
-
- std::size_t LenParameters() const { return lenParameterKind().Elements(); }
-
- // Finds a data component by name in this derived type or tis ancestors.
- const Component *FindDataComponent(
- const char *name, std::size_t nameLen) const;
-
- FILE *Dump(FILE * = stdout) const;
-
-private:
- // This member comes first because it's used like a vtable by generated code.
- // It includes all of the ancestor types' bindings, if any, first,
- // with any overrides from descendants already applied to them. Local
- // bindings then follow in alphabetic order of binding name.
- StaticDescriptor<1, true>
- binding_; // TYPE(BINDING), DIMENSION(:), POINTER, CONTIGUOUS
-
- StaticDescriptor<0> name_; // CHARACTER(:), POINTER
-
- std::uint64_t sizeInBytes_{0};
- StaticDescriptor<0, true> parent_; // TYPE(DERIVEDTYPE), POINTER
-
- // Instantiations of a parameterized derived type with KIND type
- // parameters will point this data member to the description of
- // the original uninstantiated type, which may be shared from a
- // module via use association. The original uninstantiated derived
- // type description will point to itself. Derived types that have
- // no KIND type parameters will have a null pointer here.
- StaticDescriptor<0, true> uninstantiated_; // TYPE(DERIVEDTYPE), POINTER
-
- // TODO: flags for SEQUENCE, BIND(C), any PRIVATE component(? see 7.5.2)
- std::uint64_t typeHash_{0};
-
- // These pointer targets include all of the items from the parent, if any.
- StaticDescriptor<1> kindParameter_; // pointer to rank-1 array of INTEGER(8)
- StaticDescriptor<1>
- lenParameterKind_; // pointer to rank-1 array of INTEGER(1)
-
- // This array of local data components includes the parent component.
- // Components are in component order, not collation order of their names.
- // It does not include procedure pointer components.
- StaticDescriptor<1, true>
- component_; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS
-
- // Procedure pointer components
- StaticDescriptor<1, true>
- procPtr_; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS
-
- // Does not include special bindings from ancestral types.
- StaticDescriptor<1, true>
- special_; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS
-};
+class DerivedType;
using ProcedurePointer = void (*)(); // TYPE(C_FUNPTR)
@@ -177,7 +103,8 @@ struct ProcPtrComponent {
ProcedurePointer procInitialization; // for Genre::Procedure
};
-struct SpecialBinding {
+class SpecialBinding {
+public:
enum class Which : std::uint8_t {
None = 0,
Assignment = 4,
@@ -189,13 +116,27 @@ struct SpecialBinding {
ReadUnformatted = 17,
WriteFormatted = 18,
WriteUnformatted = 19
- } which{Which::None};
+ };
+
+ Which which() const { return which_; }
+ int rank() const { return rank_; }
+ bool IsArgDescriptor(int zeroBasedArg) const {
+ return (isArgDescriptorSet_ >> zeroBasedArg) & 1;
+ }
+ template <typename PROC> PROC GetProc() const {
+ return reinterpret_cast<PROC>(proc_);
+ }
+
+ FILE *Dump(FILE *) const;
+
+private:
+ Which which_{Which::None};
// Used for Which::Final only. Which::Assignment always has rank 0, as
// type-bound defined assignment for rank > 0 must be elemental
// due to the required passed object dummy argument, which are scalar.
// User defined derived type I/O is always scalar.
- std::uint8_t rank{0};
+ std::uint8_t rank_{0};
// The following little bit-set identifies which dummy arguments are
// passed via descriptors for their derived type arguments.
@@ -222,9 +163,86 @@ struct SpecialBinding {
// the case when and only when the derived type is extensible.
// When false, the user derived type I/O subroutine must have been
// called via a generic interface, not a generic TBP.
- std::uint8_t isArgDescriptorSet{0};
+ std::uint8_t isArgDescriptorSet_{0};
+
+ ProcedurePointer proc_{nullptr};
+};
+
+class DerivedType {
+public:
+ ~DerivedType(); // never defined
+
+ const Descriptor &binding() const { return binding_.descriptor(); }
+ const Descriptor &name() const { return name_.descriptor(); }
+ std::uint64_t sizeInBytes() const { return sizeInBytes_; }
+ const Descriptor &parent() const { return parent_.descriptor(); }
+ std::uint64_t typeHash() const { return typeHash_; }
+ const Descriptor &uninstatiated() const {
+ return uninstantiated_.descriptor();
+ }
+ const Descriptor &kindParameter() const {
+ return kindParameter_.descriptor();
+ }
+ const Descriptor &lenParameterKind() const {
+ return lenParameterKind_.descriptor();
+ }
+ const Descriptor &component() const { return component_.descriptor(); }
+ const Descriptor &procPtr() const { return procPtr_.descriptor(); }
+ const Descriptor &special() const { return special_.descriptor(); }
+
+ std::size_t LenParameters() const { return lenParameterKind().Elements(); }
+
+ // Finds a data component by name in this derived type or tis ancestors.
+ const Component *FindDataComponent(
+ const char *name, std::size_t nameLen) const;
+
+ const SpecialBinding *FindSpecialBinding(SpecialBinding::Which) const;
+
+ FILE *Dump(FILE * = stdout) const;
+
+private:
+ // This member comes first because it's used like a vtable by generated code.
+ // It includes all of the ancestor types' bindings, if any, first,
+ // with any overrides from descendants already applied to them. Local
+ // bindings then follow in alphabetic order of binding name.
+ StaticDescriptor<1, true>
+ binding_; // TYPE(BINDING), DIMENSION(:), POINTER, CONTIGUOUS
+
+ StaticDescriptor<0> name_; // CHARACTER(:), POINTER
+
+ std::uint64_t sizeInBytes_{0};
+ StaticDescriptor<0, true> parent_; // TYPE(DERIVEDTYPE), POINTER
+
+ // Instantiations of a parameterized derived type with KIND type
+ // parameters will point this data member to the description of
+ // the original uninstantiated type, which may be shared from a
+ // module via use association. The original uninstantiated derived
+ // type description will point to itself. Derived types that have
+ // no KIND type parameters will have a null pointer here.
+ StaticDescriptor<0, true> uninstantiated_; // TYPE(DERIVEDTYPE), POINTER
+
+ // TODO: flags for SEQUENCE, BIND(C), any PRIVATE component(? see 7.5.2)
+ std::uint64_t typeHash_{0};
+
+ // These pointer targets include all of the items from the parent, if any.
+ StaticDescriptor<1> kindParameter_; // pointer to rank-1 array of INTEGER(8)
+ StaticDescriptor<1>
+ lenParameterKind_; // pointer to rank-1 array of INTEGER(1)
+
+ // This array of local data components includes the parent component.
+ // Components are in component order, not collation order of their names.
+ // It does not include procedure pointer components.
+ StaticDescriptor<1, true>
+ component_; // TYPE(COMPONENT), POINTER, DIMENSION(:), CONTIGUOUS
+
+ // Procedure pointer components
+ StaticDescriptor<1, true>
+ procPtr_; // TYPE(PROCPTR), POINTER, DIMENSION(:), CONTIGUOUS
- ProcedurePointer proc{nullptr};
+ // Does not include special bindings from ancestral types.
+ StaticDescriptor<1, true>
+ special_; // TYPE(SPECIALBINDING), POINTER, DIMENSION(:), CONTIGUOUS
};
+
} // namespace Fortran::runtime::typeInfo
#endif // FORTRAN_RUNTIME_TYPE_INFO_H_
diff --git a/flang/runtime/unit-map.cpp b/flang/runtime/unit-map.cpp
index 1cd2115f4aa1b..915c747371850 100644
--- a/flang/runtime/unit-map.cpp
+++ b/flang/runtime/unit-map.cpp
@@ -92,4 +92,5 @@ ExternalFileUnit &UnitMap::Create(int n, const Terminator &terminator) {
bucket_[Hash(n)].swap(chain.next); // pushes new node as list head
return chain.unit;
}
+
} // namespace Fortran::runtime::io
diff --git a/flang/runtime/unit.cpp b/flang/runtime/unit.cpp
index 79f3722fb7aba..aafb71fb6d73c 100644
--- a/flang/runtime/unit.cpp
+++ b/flang/runtime/unit.cpp
@@ -87,8 +87,11 @@ ExternalFileUnit *ExternalFileUnit::LookUpForClose(int unit) {
return GetUnitMap().LookUpForClose(unit);
}
-int ExternalFileUnit::NewUnit(const Terminator &terminator) {
- return GetUnitMap().NewUnit(terminator).unitNumber();
+ExternalFileUnit &ExternalFileUnit::NewUnit(
+ const Terminator &terminator, bool forChildIo) {
+ ExternalFileUnit &unit{GetUnitMap().NewUnit(terminator)};
+ unit.createdForInternalChildIo_ = forChildIo;
+ return unit;
}
void ExternalFileUnit::OpenUnit(std::optional<OpenStatus> status,
@@ -697,4 +700,43 @@ void ExternalFileUnit::DoEndfile(IoErrorHandler &handler) {
BeginRecord();
impliedEndfile_ = false;
}
+
+ChildIo &ExternalFileUnit::PushChildIo(IoStatementState &parent) {
+ OwningPtr<ChildIo> current{std::move(child_)};
+ Terminator &terminator{parent.GetIoErrorHandler()};
+ OwningPtr<ChildIo> next{New<ChildIo>{terminator}(parent, std::move(current))};
+ child_.reset(next.release());
+ return *child_;
+}
+
+void ExternalFileUnit::PopChildIo(ChildIo &child) {
+ if (child_.get() != &child) {
+ child.parent().GetIoErrorHandler().Crash(
+ "ChildIo being popped is not top of stack");
+ }
+ child_.reset(child.AcquirePrevious().release()); // deletes top child
+}
+
+void ChildIo::EndIoStatement() {
+ io_.reset();
+ u_.emplace<std::monostate>();
+}
+
+bool ChildIo::CheckFormattingAndDirection(Terminator &terminator,
+ const char *what, bool unformatted, Direction direction) {
+ bool parentIsUnformatted{!parent_.get_if<FormattedIoStatementState>()};
+ bool parentIsInput{!parent_.get_if<IoDirectionState<Direction::Output>>()};
+ if (unformatted != parentIsUnformatted) {
+ terminator.Crash("Child %s attempted on %s parent I/O unit", what,
+ parentIsUnformatted ? "unformatted" : "formatted");
+ return false;
+ } else if (parentIsInput != (direction == Direction::Input)) {
+ terminator.Crash("Child %s attempted on %s parent I/O unit", what,
+ parentIsInput ? "input" : "output");
+ return false;
+ } else {
+ return true;
+ }
+}
+
} // namespace Fortran::runtime::io
diff --git a/flang/runtime/unit.h b/flang/runtime/unit.h
index 9634f1a95804e..68876ff536399 100644
--- a/flang/runtime/unit.h
+++ b/flang/runtime/unit.h
@@ -28,6 +28,7 @@
namespace Fortran::runtime::io {
class UnitMap;
+class ChildIo;
class ExternalFileUnit : public ConnectionState,
public OpenFile,
@@ -36,6 +37,7 @@ class ExternalFileUnit : public ConnectionState,
explicit ExternalFileUnit(int unitNumber) : unitNumber_{unitNumber} {}
int unitNumber() const { return unitNumber_; }
bool swapEndianness() const { return swapEndianness_; }
+ bool createdForInternalChildIo() const { return createdForInternalChildIo_; }
static ExternalFileUnit *LookUp(int unit);
static ExternalFileUnit &LookUpOrCrash(int unit, const Terminator &);
@@ -46,7 +48,7 @@ class ExternalFileUnit : public ConnectionState,
static ExternalFileUnit *LookUp(const char *path);
static ExternalFileUnit &CreateNew(int unit, const Terminator &);
static ExternalFileUnit *LookUpForClose(int unit);
- static int NewUnit(const Terminator &);
+ static ExternalFileUnit &NewUnit(const Terminator &, bool forChildIo = false);
static void CloseAll(IoErrorHandler &);
static void FlushAll(IoErrorHandler &);
@@ -62,7 +64,6 @@ class ExternalFileUnit : public ConnectionState,
template <typename A, typename... X>
IoStatementState &BeginIoStatement(X &&...xs) {
- // TODO: Child data transfer statements vs. locking
lock_.Take(); // dropped in EndIoStatement()
A &state{u_.emplace<A>(std::forward<X>(xs)...)};
if constexpr (!std::is_same_v<A, OpenStatementState>) {
@@ -91,6 +92,10 @@ class ExternalFileUnit : public ConnectionState,
BeginRecord();
}
+ ChildIo *GetChildIo() { return child_.get(); }
+ ChildIo &PushChildIo(IoStatementState &);
+ void PopChildIo(ChildIo &);
+
private:
static UnitMap &GetUnitMap();
const char *FrameNextInput(IoErrorHandler &, std::size_t);
@@ -116,8 +121,8 @@ class ExternalFileUnit : public ConnectionState,
ExternalFormattedIoStatementState<Direction::Input>,
ExternalListIoStatementState<Direction::Output>,
ExternalListIoStatementState<Direction::Input>,
- UnformattedIoStatementState<Direction::Output>,
- UnformattedIoStatementState<Direction::Input>, InquireUnitState,
+ ExternalUnformattedIoStatementState<Direction::Output>,
+ ExternalUnformattedIoStatementState<Direction::Input>, InquireUnitState,
ExternalMiscIoStatementState>
u_;
@@ -132,6 +137,50 @@ class ExternalFileUnit : public ConnectionState,
std::size_t recordOffsetInFrame_{0}; // of currentRecordNumber
bool swapEndianness_{false};
+
+ bool createdForInternalChildIo_{false};
+
+ // A stack of child I/O pseudo-units for user-defined derived type
+ // I/O that have this unit number.
+ OwningPtr<ChildIo> child_;
+};
+
+// A pseudo-unit for child I/O statements in user-defined derived type
+// I/O subroutines; it forwards operations to the parent I/O statement,
+// which can also be a child I/O statement.
+class ChildIo {
+public:
+ ChildIo(IoStatementState &parent, OwningPtr<ChildIo> &&previous)
+ : parent_{parent}, previous_{std::move(previous)} {}
+
+ IoStatementState &parent() const { return parent_; }
+
+ void EndIoStatement();
+
+ template <typename A, typename... X>
+ IoStatementState &BeginIoStatement(X &&...xs) {
+ A &state{u_.emplace<A>(std::forward<X>(xs)...)};
+ io_.emplace(state);
+ return *io_;
+ }
+
+ OwningPtr<ChildIo> AcquirePrevious() { return std::move(previous_); }
+
+ bool CheckFormattingAndDirection(
+ Terminator &, const char *what, bool unformatted, Direction);
+
+private:
+ IoStatementState &parent_;
+ OwningPtr<ChildIo> previous_;
+ std::variant<std::monostate,
+ ChildFormattedIoStatementState<Direction::Output>,
+ ChildFormattedIoStatementState<Direction::Input>,
+ ChildListIoStatementState<Direction::Output>,
+ ChildListIoStatementState<Direction::Input>,
+ ChildUnformattedIoStatementState<Direction::Output>,
+ ChildUnformattedIoStatementState<Direction::Input>>
+ u_;
+ std::optional<IoStatementState> io_;
};
} // namespace Fortran::runtime::io
diff --git a/flang/test/Semantics/typeinfo01.f90 b/flang/test/Semantics/typeinfo01.f90
index a68c392ad7513..088c6e56b6b76 100644
--- a/flang/test/Semantics/typeinfo01.f90
+++ b/flang/test/Semantics/typeinfo01.f90
@@ -171,7 +171,7 @@ subroutine wu(x,u,iostat,iomsg)
end module
module m10
- type :: t
+ type, bind(c) :: t ! non-extensible
end type
interface read(formatted)
procedure :: rf
More information about the flang-commits
mailing list