diff --git a/flang/include/flang/Runtime/io-api.h b/flang/include/flang/Runtime/io-api.h --- a/flang/include/flang/Runtime/io-api.h +++ b/flang/include/flang/Runtime/io-api.h @@ -59,6 +59,8 @@ // Cookie cookie{BeginExternalListOutput(DefaultUnit,__FILE__,__LINE__)}; // OutputInteger32(cookie, 666); // EndIoStatement(cookie); +// Formatted I/O with explicit formats can supply the format as a +// const char * pointer with a length, or with a descriptor. // Internal I/O initiation // Internal I/O can loan the runtime library an optional block of memory @@ -86,11 +88,11 @@ Cookie IONAME(BeginInternalArrayFormattedOutput)(const Descriptor &, const char *format, std::size_t formatLength, void **scratchArea = nullptr, std::size_t scratchBytes = 0, const char *sourceFile = nullptr, - int sourceLine = 0); + int sourceLine = 0, const Descriptor *formatDescriptor = nullptr); Cookie IONAME(BeginInternalArrayFormattedInput)(const Descriptor &, const char *format, std::size_t formatLength, void **scratchArea = nullptr, std::size_t scratchBytes = 0, const char *sourceFile = nullptr, - int sourceLine = 0); + int sourceLine = 0, const Descriptor *formatDescriptor = nullptr); // Internal I/O to/from a default-kind character scalar can avoid a // descriptor. @@ -105,11 +107,13 @@ Cookie IONAME(BeginInternalFormattedOutput)(char *internal, std::size_t internalLength, const char *format, std::size_t formatLength, void **scratchArea = nullptr, std::size_t scratchBytes = 0, - const char *sourceFile = nullptr, int sourceLine = 0); + const char *sourceFile = nullptr, int sourceLine = 0, + const Descriptor *formatDescriptor = nullptr); Cookie IONAME(BeginInternalFormattedInput)(const char *internal, std::size_t internalLength, const char *format, std::size_t formatLength, void **scratchArea = nullptr, std::size_t scratchBytes = 0, - const char *sourceFile = nullptr, int sourceLine = 0); + const char *sourceFile = nullptr, int sourceLine = 0, + const Descriptor *formatDescriptor = nullptr); // External unit numbers must fit in default integers. When the integer // provided as UNIT is of a wider type than the default integer, it could @@ -134,10 +138,10 @@ const char *sourceFile = nullptr, int sourceLine = 0); Cookie IONAME(BeginExternalFormattedOutput)(const char *format, std::size_t, ExternalUnit = DefaultUnit, const char *sourceFile = nullptr, - int sourceLine = 0); + int sourceLine = 0, const Descriptor *formatDescriptor = nullptr); Cookie IONAME(BeginExternalFormattedInput)(const char *format, std::size_t, ExternalUnit = DefaultUnit, const char *sourceFile = nullptr, - int sourceLine = 0); + int sourceLine = 0, const Descriptor *formatDescriptor = nullptr); Cookie IONAME(BeginUnformattedOutput)(ExternalUnit = DefaultUnit, const char *sourceFile = nullptr, int sourceLine = 0); Cookie IONAME(BeginUnformattedInput)(ExternalUnit = DefaultUnit, diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp --- a/flang/lib/Semantics/check-io.cpp +++ b/flang/lib/Semantics/check-io.cpp @@ -252,13 +252,6 @@ "Format expression must be default character or default scalar integer"_err_en_US); return; } - if (expr->Rank() > 0 && - !IsSimplyContiguous(*expr, context_.foldingContext())) { - // The runtime APIs don't allow arbitrary descriptors for formats. - context_.Say(format.source, - "Format expression must be a simply contiguous array if not scalar"_err_en_US); - return; - } flags_.set(Flag::CharFmt); const std::optional constantFormat{ GetConstExpr(format)}; diff --git a/flang/runtime/format-implementation.h b/flang/runtime/format-implementation.h --- a/flang/runtime/format-implementation.h +++ b/flang/runtime/format-implementation.h @@ -14,20 +14,47 @@ #include "emit-encoded.h" #include "format.h" #include "io-stmt.h" +#include "memory.h" #include "flang/Common/format.h" #include "flang/Decimal/decimal.h" #include "flang/Runtime/main.h" #include +#include #include namespace Fortran::runtime::io { template FormatControl::FormatControl(const Terminator &terminator, - const CharType *format, std::size_t formatLength, int maxHeight) + const CharType *format, std::size_t formatLength, + const Descriptor *formatDescriptor, int maxHeight) : maxHeight_{static_cast(maxHeight)}, format_{format}, formatLength_{static_cast(formatLength)} { RUNTIME_CHECK(terminator, maxHeight == maxHeight_); + if (!format && formatDescriptor) { + // The format is a character array passed via a descriptor. + formatLength = formatDescriptor->SizeInBytes() / sizeof(CharType); + formatLength_ = static_cast(formatLength); + if (formatDescriptor->IsContiguous()) { + // Treat the contiguous array as a single character value. + format = const_cast( + reinterpret_cast(formatDescriptor->raw().base_addr)); + } else { + // Concatenate its elements into a temporary array. + char *p{reinterpret_cast( + AllocateMemoryOrCrash(terminator, formatLength * sizeof(CharType)))}; + format = p; + SubscriptValue at[maxRank]; + formatDescriptor->GetLowerBounds(at); + auto elementBytes{formatDescriptor->ElementBytes()}; + for (std::size_t j{0}; j < formatLength; ++j) { + std::memcpy(p, formatDescriptor->Element(at), elementBytes); + p += elementBytes; + formatDescriptor->IncrementSubscripts(at); + } + freeFormat_ = true; + } + } RUNTIME_CHECK( terminator, formatLength == static_cast(formatLength_)); stack_[0].start = offset_; @@ -474,6 +501,9 @@ template void FormatControl::Finish(Context &context) { CueUpNextDataEdit(context, true /* stop at colon or end of FORMAT */); + if (freeFormat_) { + FreeMemory(const_cast(format_)); + } } } // namespace Fortran::runtime::io #endif // FORTRAN_RUNTIME_FORMAT_IMPLEMENTATION_H_ diff --git a/flang/runtime/format.h b/flang/runtime/format.h --- a/flang/runtime/format.h +++ b/flang/runtime/format.h @@ -18,6 +18,10 @@ #include #include +namespace Fortran::runtime { +class Descriptor; +} // namespace Fortran::runtime + namespace Fortran::runtime::io { class IoStatementState; @@ -86,7 +90,8 @@ FormatControl() {} FormatControl(const Terminator &, const CharType *format, - std::size_t formatLength, int maxHeight = maxMaxHeight); + std::size_t formatLength, const Descriptor *formatDescriptor = nullptr, + int maxHeight = maxMaxHeight); // For attempting to allocate in a user-supplied stack area static std::size_t GetNeededSize(int maxHeight) { @@ -177,8 +182,9 @@ // user program for internal I/O. const std::uint8_t maxHeight_{maxMaxHeight}; std::uint8_t height_{0}; + bool freeFormat_{false}; const CharType *format_{nullptr}; - int formatLength_{0}; + int formatLength_{0}; // in units of characters int offset_{0}; // next item is at format_[offset_] // must be last, may be incomplete diff --git a/flang/runtime/io-api.cpp b/flang/runtime/io-api.cpp --- a/flang/runtime/io-api.cpp +++ b/flang/runtime/io-api.cpp @@ -70,26 +70,31 @@ template Cookie BeginInternalArrayFormattedIO(const Descriptor &descriptor, const char *format, std::size_t formatLength, void ** /*scratchArea*/, - std::size_t /*scratchBytes*/, const char *sourceFile, int sourceLine) { + std::size_t /*scratchBytes*/, const char *sourceFile, int sourceLine, + const Descriptor *formatDescriptor) { Terminator oom{sourceFile, sourceLine}; - return &New>{oom}( - descriptor, format, formatLength, sourceFile, sourceLine) + return &New>{oom}(descriptor, format, + formatLength, sourceFile, sourceLine, formatDescriptor) .release() ->ioStatementState(); } Cookie IONAME(BeginInternalArrayFormattedOutput)(const Descriptor &descriptor, const char *format, std::size_t formatLength, void **scratchArea, - std::size_t scratchBytes, const char *sourceFile, int sourceLine) { + std::size_t scratchBytes, const char *sourceFile, int sourceLine, + const Descriptor *formatDescriptor) { return BeginInternalArrayFormattedIO(descriptor, format, - formatLength, scratchArea, scratchBytes, sourceFile, sourceLine); + formatLength, scratchArea, scratchBytes, sourceFile, sourceLine, + formatDescriptor); } Cookie IONAME(BeginInternalArrayFormattedInput)(const Descriptor &descriptor, const char *format, std::size_t formatLength, void **scratchArea, - std::size_t scratchBytes, const char *sourceFile, int sourceLine) { + std::size_t scratchBytes, const char *sourceFile, int sourceLine, + const Descriptor *formatDescriptor) { return BeginInternalArrayFormattedIO(descriptor, format, - formatLength, scratchArea, scratchBytes, sourceFile, sourceLine); + formatLength, scratchArea, scratchBytes, sourceFile, sourceLine, + formatDescriptor); } template @@ -123,10 +128,12 @@ std::conditional_t *internal, std::size_t internalLength, const char *format, std::size_t formatLength, void ** /*scratchArea*/, std::size_t /*scratchBytes*/, - const char *sourceFile, int sourceLine) { + const char *sourceFile, int sourceLine, + const Descriptor *formatDescriptor) { Terminator oom{sourceFile, sourceLine}; - return &New>{oom}( - internal, internalLength, format, formatLength, sourceFile, sourceLine) + return &New>{oom}(internal, + internalLength, format, formatLength, sourceFile, sourceLine, + formatDescriptor) .release() ->ioStatementState(); } @@ -134,17 +141,19 @@ Cookie IONAME(BeginInternalFormattedOutput)(char *internal, std::size_t internalLength, const char *format, std::size_t formatLength, void **scratchArea, std::size_t scratchBytes, const char *sourceFile, - int sourceLine) { + int sourceLine, const Descriptor *formatDescriptor) { return BeginInternalFormattedIO(internal, internalLength, - format, formatLength, scratchArea, scratchBytes, sourceFile, sourceLine); + format, formatLength, scratchArea, scratchBytes, sourceFile, sourceLine, + formatDescriptor); } Cookie IONAME(BeginInternalFormattedInput)(const char *internal, std::size_t internalLength, const char *format, std::size_t formatLength, void **scratchArea, std::size_t scratchBytes, const char *sourceFile, - int sourceLine) { + int sourceLine, const Descriptor *formatDescriptor) { return BeginInternalFormattedIO(internal, internalLength, - format, formatLength, scratchArea, scratchBytes, sourceFile, sourceLine); + format, formatLength, scratchArea, scratchBytes, sourceFile, sourceLine, + formatDescriptor); } static Cookie NoopUnit(const Terminator &terminator, int unitNumber, @@ -235,7 +244,8 @@ template Cookie BeginExternalFormattedIO(const char *format, std::size_t formatLength, - ExternalUnit unitNumber, const char *sourceFile, int sourceLine) { + ExternalUnit unitNumber, const char *sourceFile, int sourceLine, + const Descriptor *formatDescriptor) { Terminator terminator{sourceFile, sourceLine}; if (unitNumber == DefaultUnit) { unitNumber = DIR == Direction::Input ? 5 : 6; @@ -259,7 +269,8 @@ } if (iostat == IostatOk) { return &child->BeginIoStatement>( - *child, format, formatLength, sourceFile, sourceLine); + *child, format, formatLength, sourceFile, sourceLine, + formatDescriptor); } else { return &child->BeginIoStatement( iostat, nullptr /* no unit */, sourceFile, sourceLine); @@ -270,7 +281,8 @@ } if (iostat == IostatOk) { return &unit->BeginIoStatement>( - terminator, *unit, format, formatLength, sourceFile, sourceLine); + terminator, *unit, format, formatLength, sourceFile, sourceLine, + formatDescriptor); } else { return &unit->BeginIoStatement( terminator, iostat, unit, sourceFile, sourceLine); @@ -280,16 +292,16 @@ Cookie IONAME(BeginExternalFormattedOutput)(const char *format, std::size_t formatLength, ExternalUnit unitNumber, const char *sourceFile, - int sourceLine) { - return BeginExternalFormattedIO( - format, formatLength, unitNumber, sourceFile, sourceLine); + int sourceLine, const Descriptor *formatDescriptor) { + return BeginExternalFormattedIO(format, formatLength, + unitNumber, sourceFile, sourceLine, formatDescriptor); } Cookie IONAME(BeginExternalFormattedInput)(const char *format, std::size_t formatLength, ExternalUnit unitNumber, const char *sourceFile, - int sourceLine) { - return BeginExternalFormattedIO( - format, formatLength, unitNumber, sourceFile, sourceLine); + int sourceLine, const Descriptor *formatDescriptor) { + return BeginExternalFormattedIO(format, formatLength, + unitNumber, sourceFile, sourceLine, formatDescriptor); } template diff --git a/flang/runtime/io-stmt.h b/flang/runtime/io-stmt.h --- a/flang/runtime/io-stmt.h +++ b/flang/runtime/io-stmt.h @@ -358,10 +358,11 @@ using typename InternalIoStatementState::Buffer; InternalFormattedIoStatementState(Buffer internal, std::size_t internalLength, const CharType *format, std::size_t formatLength, - const char *sourceFile = nullptr, int sourceLine = 0); + const char *sourceFile = nullptr, int sourceLine = 0, + const Descriptor *formatDescriptor = nullptr); InternalFormattedIoStatementState(const Descriptor &, const CharType *format, std::size_t formatLength, const char *sourceFile = nullptr, - int sourceLine = 0); + int sourceLine = 0, const Descriptor *formatDescriptor = nullptr); IoStatementState &ioStatementState() { return ioStatementState_; } void CompleteOperation(); int EndIoStatement(); @@ -444,7 +445,7 @@ using CharType = CHAR; ExternalFormattedIoStatementState(ExternalFileUnit &, const CharType *format, std::size_t formatLength, const char *sourceFile = nullptr, - int sourceLine = 0); + int sourceLine = 0, const Descriptor *formatDescriptor = nullptr); void CompleteOperation(); int EndIoStatement(); std::optional GetNextDataEdit( @@ -500,7 +501,7 @@ using CharType = CHAR; ChildFormattedIoStatementState(ChildIo &, const CharType *format, std::size_t formatLength, const char *sourceFile = nullptr, - int sourceLine = 0); + int sourceLine = 0, const Descriptor *formatDescriptor = nullptr); MutableModes &mutableModes() { return mutableModes_; } void CompleteOperation(); int EndIoStatement(); diff --git a/flang/runtime/io-stmt.cpp b/flang/runtime/io-stmt.cpp --- a/flang/runtime/io-stmt.cpp +++ b/flang/runtime/io-stmt.cpp @@ -140,16 +140,19 @@ template InternalFormattedIoStatementState::InternalFormattedIoStatementState( Buffer buffer, std::size_t length, const CharType *format, - std::size_t formatLength, const char *sourceFile, int sourceLine) + std::size_t formatLength, const char *sourceFile, int sourceLine, + const Descriptor *formatDescriptor) : InternalIoStatementState{buffer, length, sourceFile, sourceLine}, - ioStatementState_{*this}, format_{*this, format, formatLength} {} + ioStatementState_{*this}, format_{*this, format, formatLength, + formatDescriptor} {} template InternalFormattedIoStatementState::InternalFormattedIoStatementState( const Descriptor &d, const CharType *format, std::size_t formatLength, - const char *sourceFile, int sourceLine) + const char *sourceFile, int sourceLine, const Descriptor *formatDescriptor) : InternalIoStatementState{d, sourceFile, sourceLine}, - ioStatementState_{*this}, format_{*this, format, formatLength} {} + ioStatementState_{*this}, format_{*this, format, formatLength, + formatDescriptor} {} template void InternalFormattedIoStatementState::CompleteOperation() { @@ -395,9 +398,9 @@ template ExternalFormattedIoStatementState::ExternalFormattedIoStatementState( ExternalFileUnit &unit, const CHAR *format, std::size_t formatLength, - const char *sourceFile, int sourceLine) + const char *sourceFile, int sourceLine, const Descriptor *formatDescriptor) : ExternalIoStatementState{unit, sourceFile, sourceLine}, - format_{*this, format, formatLength} {} + format_{*this, format, formatLength, formatDescriptor} {} template void ExternalFormattedIoStatementState::CompleteOperation() { @@ -850,10 +853,11 @@ template ChildFormattedIoStatementState::ChildFormattedIoStatementState( ChildIo &child, const CHAR *format, std::size_t formatLength, - const char *sourceFile, int sourceLine) + const char *sourceFile, int sourceLine, const Descriptor *formatDescriptor) : ChildIoStatementState{child, sourceFile, sourceLine}, mutableModes_{child.parent().mutableModes()}, format_{*this, format, - formatLength} {} + formatLength, + formatDescriptor} {} template void ChildFormattedIoStatementState::CompleteOperation() { diff --git a/flang/test/Semantics/assign06.f90 b/flang/test/Semantics/assign06.f90 --- a/flang/test/Semantics/assign06.f90 +++ b/flang/test/Semantics/assign06.f90 @@ -11,8 +11,8 @@ integer(kind=1) :: badlab1 real :: badlab2 integer :: badlab3(1) - real, pointer :: badlab4(:) ! not contiguous - real, pointer, contiguous :: oklab4(:) + character, pointer :: badlab4(:) ! not contiguous + character, pointer, contiguous :: oklab4(:) assign 1 to lab ! ok assign 1 to implicitlab1 ! ok !ERROR: 'badlab1' must be a default integer scalar variable @@ -44,9 +44,9 @@ !Legacy extension cases write(*,fmt=badlab2) write(*,fmt=badlab3) - !ERROR: Format expression must be a simply contiguous array if not scalar - write(*,fmt=badlab4) - write(*,fmt=badlab5) ! ok legacy extension + !Array cases + write(*,fmt=badlab4) ! ok + write(*,fmt=badlab5) ! ok 1 continue 3 format('yes') end subroutine test