[flang] Support for character array formats

[klausler]

Summary

A character array can be used as a format in an I/O data transfer
statement, with the interpretation that its elements are concatenated
in element order to constitute the format.

Support in the runtime with an extra optional descriptor argument
to six I/O API calls; support in semantics by removing an earlier
check for a simply contiguous array presented as a format.

Some work needs to be done in lowering to pass a character array
descriptor to the I/O runtime API when present

[kiranchandramohan]

@klausler SNAP fails with this patch. https://github.com/banach-space/llvm-project/runs/7910556327?check_suite_focus=true

/home/runner/work/llvm-project/llvm-project/build//bin/flang-new  -c time.f90
error: loc("./time.f90":19:7): 'llvm.call' op incorrect number of operands (5) for callee (expecting: 6)
error: Lowering to LLVM IR failed
Incorrect number of arguments passed to called function!
  %14 = call ptr @_FortranAioBeginExternalFormattedOutput(ptr @_QQcl.473dced66a7e38e9ed6cb48a04ca778d, i64 42, i32 11, ptr @_QQcl.2E2F74696D652E66393000, i32 19), !dbg !15

Reproducer from SNAP

  SUBROUTINE time_summ
  CHARACTER(LEN=1) :: star='*'
  INTEGER :: i
  WRITE(*, 401) ( star, i = 1, 80 )
401 FORMAT( 10X, 'keyword Timing Summary', /, 80A, / )
  END SUBROUTINE

I see that you already mention that some work is needed in lowering. Is someone working on this part? Shall we revert this patch until then? We can have a look if no one is working on this.

Some work needs to be done in lowering to pass a character array
descriptor to the I/O runtime API when present

[DavidSpickett]

Our bot also has failures and bisect pointed here. This is just one reproducer I got, so I can't be 100% they're all due to this but I see 132 instances of it in the log, and there are 173 missing exe.

https://lab.llvm.org/buildbot/#/builders/179/builds/4281

error: loc("./FM901-9bde42":47:7): 'llvm.call' op incorrect number of operands (5) for callee (expecting: 6)
error: Lowering to LLVM IR failed
flang-new: /home/david.spickett/llvm-project/llvm/lib/IR/Instructions.cpp:525: void llvm::CallInst::init(llvm::FunctionType *, llvm::Value *, ArrayRef<llvm::Value *>, ArrayRef<llvm::OperandBundleDef>, const llvm::Twine &): Assertion `(Args.size() == FTy->getNumParams() || (FTy->isVarArg() && Args.size() > FTy->getNumParams())) && "Calling a function with bad signature!"' failed.

Repro:

FM901-9bde42.zip2 KBDownload

Though I think it's just https://github.com/llvm/llvm-test-suite/blob/main/Fortran/UnitTests/fcvs21_f95/FM901.f with formatting changes.

[klausler]

A corresponding patch to lowering is coming.

[klausler]

Fix to mlir error in https://reviews.llvm.org/D132259, commit d0e03bf06b2a7c05d8c478845282a68cba7cdda2.

flang/include/flang/Runtime/io-api.h

 
 #define IONAME(name) RTNAME(io##name)
 
 // These functions initiate data transfer statements (READ, WRITE, PRINT).
 // Example: PRINT *, 666 is implemented as the series of calls:
 //   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
 // in which the library can maintain state across the calls that implement
 // the internal transfer; use of these blocks can reduce the need for dynamic
 // memory allocation &/or thread-local storage.  The block must be sufficiently
 // aligned to hold a pointer.
 constexpr std::size_t RecommendedInternalIoScratchAreaBytes(
Cookie IONAME(BeginInternalArrayListOutput)(const Descriptor &,
     void **scratchArea = nullptr, std::size_t scratchBytes = 0,
     const char *sourceFile = nullptr, int sourceLine = 0);
 Cookie IONAME(BeginInternalArrayListInput)(const Descriptor &,
     void **scratchArea = nullptr, std::size_t scratchBytes = 0,
     const char *sourceFile = nullptr, int sourceLine = 0);
 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.
 Cookie IONAME(BeginInternalListOutput)(char *internal,
     std::size_t internalLength, void **scratchArea = nullptr,
     std::size_t scratchBytes = 0, const char *sourceFile = nullptr,
     int sourceLine = 0);
 Cookie IONAME(BeginInternalListInput)(const char *internal,
     std::size_t internalLength, void **scratchArea = nullptr,
     std::size_t scratchBytes = 0, const char *sourceFile = nullptr,
     int sourceLine = 0);
 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
 // overflow when converted to a default integer.
 // CheckUnitNumberInRange should be called to verify that a unit number of a
 // wide integer type can fit in a default integer. Since it should be called
 // before the BeginXXX(unit, ...) call, it has its own error handling interface.
 // If handleError is false, and the unit number is out of range, the program
 // will be terminated. Otherwise, if unit is out of range, a nonzero Iostat
 // code is returned and ioMsg is set if it is not a nullptr.
 enum Iostat IONAME(CheckUnitNumberInRange64)(std::int64_t unit,
     bool handleError, char *ioMsg = nullptr, std::size_t ioMsgLength = 0,
     const char *sourceFile = nullptr, int sourceLine = 0);
 enum Iostat IONAME(CheckUnitNumberInRange128)(common::int128_t unit,
     bool handleError, char *ioMsg = nullptr, std::size_t ioMsgLength = 0,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // External synchronous I/O initiation
 Cookie IONAME(BeginExternalListOutput)(ExternalUnit = DefaultUnit,
     const char *sourceFile = nullptr, int sourceLine = 0);
 Cookie IONAME(BeginExternalListInput)(ExternalUnit = DefaultUnit,
     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,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // WAIT(ID=)
 Cookie IONAME(BeginWait)(ExternalUnit, AsynchronousId,
     const char *sourceFile = nullptr, int sourceLine = 0);

flang/lib/Semantics/check-io.cpp

common::visit(
               }
             } else if (!type ||
                 type->kind() !=
                     context_.defaultKinds().GetDefaultKind(type->category())) {
               context_.Say(format.source,
                   "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<std::string> constantFormat{
                 GetConstExpr<std::string>(format)};
             if (!constantFormat) {
               return;
             }
             // validate constant format -- 12.6.2.2
             bool isFolded{constantFormat->size() != format.source.size() - 2};

flang/runtime/format-implementation.h

 //===-- runtime/format-implementation.h -------------------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 // Implements out-of-line member functions of template class FormatControl
 
 #ifndef FORTRAN_RUNTIME_FORMAT_IMPLEMENTATION_H_
 #define FORTRAN_RUNTIME_FORMAT_IMPLEMENTATION_H_
 
 #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 <algorithm>
+#include <cstring>
 #include <limits>
 
 namespace Fortran::runtime::io {
 
 template <typename CONTEXT>
 FormatControl<CONTEXT>::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<std::uint8_t>(maxHeight)}, format_{format},
       formatLength_{static_cast<int>(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<int>(formatLength);
+    if (formatDescriptor->IsContiguous()) {
+      // Treat the contiguous array as a single character value.
+      format = const_cast<const CharType *>(
+          reinterpret_cast<CharType *>(formatDescriptor->raw().base_addr));
+    } else {
+      // Concatenate its elements into a temporary array.
+      char *p{reinterpret_cast<char *>(
+          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<char>(at), elementBytes);
+        p += elementBytes;
+        formatDescriptor->IncrementSubscripts(at);
+      }
+      freeFormat_ = true;
+    }
+  }
   RUNTIME_CHECK(
       terminator, formatLength == static_cast<std::size_t>(formatLength_));
   stack_[0].start = offset_;
   stack_[0].remaining = Iteration::unlimited; // 13.4(8)
 }
 
 template <typename CONTEXT>
 int FormatControl<CONTEXT>::GetIntField(
if (repeat > maxRepeat) {
     ++height_;
   }
   return edit;
 }
 
 template <typename CONTEXT>
 void FormatControl<CONTEXT>::Finish(Context &context) {
   CueUpNextDataEdit(context, true /* stop at colon or end of FORMAT */);
+  if (freeFormat_) {
+    FreeMemory(const_cast<CharType *>(format_));
+  }
 }
 } // namespace Fortran::runtime::io
 #endif // FORTRAN_RUNTIME_FORMAT_IMPLEMENTATION_H_

flang/runtime/format.h

 
 #include "environment.h"
 #include "io-error.h"
 #include "flang/Common/Fortran.h"
 #include "flang/Decimal/decimal.h"
 #include <cinttypes>
 #include <optional>
 
+namespace Fortran::runtime {
+class Descriptor;
+} // namespace Fortran::runtime
+
 namespace Fortran::runtime::io {
 
 class IoStatementState;
 
 enum EditingFlags {
   blankZero = 1, // BLANK=ZERO or BZ edit
   decimalComma = 2, // DECIMAL=COMMA or DC edit
   signPlus = 4, // SIGN=PLUS or SP edit

 // Errors are fatal.  See subclause 13.4 in Fortran 2018 for background.
 template <typename CONTEXT> class FormatControl {
 public:
   using Context = CONTEXT;
   using CharType = char; // formats are always default kind CHARACTER
 
   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) {
     return sizeof(FormatControl) -
         sizeof(Iteration) * (maxMaxHeight - maxHeight);
   }
 
   // Extracts the next data edit descriptor, handling control edit descriptors
void ReportBadFormat(Context &context, const char *msg, int offset) const {
     context.SignalError(IostatErrorInFormat, "%s; at offset %d", msg, offset);
   }
 
   // Data members are arranged and typed so as to reduce size.
   // This structure may be allocated in stack space loaned by the
   // 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
   Iteration stack_[maxMaxHeight];
 };
 } // namespace Fortran::runtime::io
 #endif // FORTRAN_RUNTIME_FORMAT_H_

flang/runtime/io-api.cpp

Cookie IONAME(BeginInternalArrayListInput)(const Descriptor &descriptor,
     int sourceLine) {
   return BeginInternalArrayListIO<Direction::Input>(
       descriptor, scratchArea, scratchBytes, sourceFile, sourceLine);
 }
 
 template <Direction DIR>
 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<InternalFormattedIoStatementState<DIR>>{oom}(
-      descriptor, format, formatLength, sourceFile, sourceLine)
+  return &New<InternalFormattedIoStatementState<DIR>>{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<Direction::Output>(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<Direction::Input>(descriptor, format,
-      formatLength, scratchArea, scratchBytes, sourceFile, sourceLine);
+      formatLength, scratchArea, scratchBytes, sourceFile, sourceLine,
+      formatDescriptor);
 }
 
 template <Direction DIR>
 Cookie BeginInternalListIO(
     std::conditional_t<DIR == Direction::Input, const char, char> *internal,
     std::size_t internalLength, void ** /*scratchArea*/,
     std::size_t /*scratchBytes*/, const char *sourceFile, int sourceLine) {
   Terminator oom{sourceFile, sourceLine};
return BeginInternalListIO<Direction::Input>(internal, internalLength,
       scratchArea, scratchBytes, sourceFile, sourceLine);
 }
 
 template <Direction DIR>
 Cookie BeginInternalFormattedIO(
     std::conditional_t<DIR == Direction::Input, const char, char> *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<InternalFormattedIoStatementState<DIR>>{oom}(
-      internal, internalLength, format, formatLength, sourceFile, sourceLine)
+  return &New<InternalFormattedIoStatementState<DIR>>{oom}(internal,
+      internalLength, format, formatLength, sourceFile, sourceLine,
+      formatDescriptor)
               .release()
               ->ioStatementState();
 }
 
 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<Direction::Output>(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<Direction::Input>(internal, internalLength,
-      format, formatLength, scratchArea, scratchBytes, sourceFile, sourceLine);
+      format, formatLength, scratchArea, scratchBytes, sourceFile, sourceLine,
+      formatDescriptor);
 }
 
 static Cookie NoopUnit(const Terminator &terminator, int unitNumber,
     enum Iostat iostat = IostatOk) {
   Cookie cookie{&New<NoopStatementState>{terminator}(
       terminator.sourceFileName(), terminator.sourceLine(), unitNumber)
                      .release()
                      ->ioStatementState()};

 Cookie IONAME(BeginExternalListInput)(
     ExternalUnit unitNumber, const char *sourceFile, int sourceLine) {
   return BeginExternalListIO<Direction::Input, ExternalListIoStatementState>(
       unitNumber, sourceFile, sourceLine);
 }
 
 template <Direction DIR>
 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;
   }
   Cookie errorCookie{nullptr};
   ExternalFileUnit *unit{GetOrCreateUnit(
       unitNumber, DIR, false /*!unformatted*/, terminator, errorCookie)};
   if (!unit) {
     return errorCookie;
   }
   Iostat iostat{IostatOk};
   if (!unit->isUnformatted.has_value()) {
     unit->isUnformatted = false;
   }
   if (*unit->isUnformatted) {
     iostat = IostatFormattedIoOnUnformattedUnit;
   }
   if (ChildIo * child{unit->GetChildIo()}) {
     if (iostat == IostatOk) {
       iostat = child->CheckFormattingAndDirection(false, DIR);
     }
     if (iostat == IostatOk) {
       return &child->BeginIoStatement<ChildFormattedIoStatementState<DIR>>(
-          *child, format, formatLength, sourceFile, sourceLine);
+          *child, format, formatLength, sourceFile, sourceLine,
+          formatDescriptor);
     } else {
       return &child->BeginIoStatement<ErroneousIoStatementState>(
           iostat, nullptr /* no unit */, sourceFile, sourceLine);
     }
   } else {
     if (iostat == IostatOk) {
       iostat = unit->SetDirection(DIR);
     }
     if (iostat == IostatOk) {
       return &unit->BeginIoStatement<ExternalFormattedIoStatementState<DIR>>(
-          terminator, *unit, format, formatLength, sourceFile, sourceLine);
+          terminator, *unit, format, formatLength, sourceFile, sourceLine,
+          formatDescriptor);
     } else {
       return &unit->BeginIoStatement<ErroneousIoStatementState>(
           terminator, iostat, unit, sourceFile, sourceLine);
     }
   }
 }
 
 Cookie IONAME(BeginExternalFormattedOutput)(const char *format,
     std::size_t formatLength, ExternalUnit unitNumber, const char *sourceFile,
-    int sourceLine) {
-  return BeginExternalFormattedIO<Direction::Output>(
-      format, formatLength, unitNumber, sourceFile, sourceLine);
+    int sourceLine, const Descriptor *formatDescriptor) {
+  return BeginExternalFormattedIO<Direction::Output>(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<Direction::Input>(
-      format, formatLength, unitNumber, sourceFile, sourceLine);
+    int sourceLine, const Descriptor *formatDescriptor) {
+  return BeginExternalFormattedIO<Direction::Input>(format, formatLength,
+      unitNumber, sourceFile, sourceLine, formatDescriptor);
 }
 
 template <Direction DIR>
 Cookie BeginUnformattedIO(
     ExternalUnit unitNumber, const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
   Cookie errorCookie{nullptr};
   ExternalFileUnit *unit{GetOrCreateUnit(

flang/runtime/io-stmt.h

 class InternalFormattedIoStatementState
     : public InternalIoStatementState<DIR>,
       public FormattedIoStatementState<DIR> {
 public:
   using CharType = CHAR;
   using typename InternalIoStatementState<DIR>::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();
   std::optional<DataEdit> GetNextDataEdit(
       IoStatementState &, int maxRepeat = 1) {
     return format_.GetNextDataEdit(*this, maxRepeat);
   }
 

 template <Direction DIR, typename CHAR>
 class ExternalFormattedIoStatementState
     : public ExternalIoStatementState<DIR>,
       public FormattedIoStatementState<DIR> {
 public:
   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<DataEdit> GetNextDataEdit(
       IoStatementState &, int maxRepeat = 1) {
     return format_.GetNextDataEdit(*this, maxRepeat);
   }
 
 private:

 
 template <Direction DIR, typename CHAR>
 class ChildFormattedIoStatementState : public ChildIoStatementState<DIR>,
                                        public FormattedIoStatementState<DIR> {
 public:
   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();
   bool AdvanceRecord(int = 1);
   std::optional<DataEdit> GetNextDataEdit(
       IoStatementState &, int maxRepeat = 1) {
     return format_.GetNextDataEdit(*this, maxRepeat);
   }

flang/runtime/io-stmt.cpp

 template <Direction DIR>
 void InternalIoStatementState<DIR>::HandleRelativePosition(std::int64_t n) {
   return unit_.HandleRelativePosition(n);
 }
 
 template <Direction DIR, typename CHAR>
 InternalFormattedIoStatementState<DIR, CHAR>::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<DIR>{buffer, length, sourceFile, sourceLine},
-      ioStatementState_{*this}, format_{*this, format, formatLength} {}
+      ioStatementState_{*this}, format_{*this, format, formatLength,
+                                    formatDescriptor} {}
 
 template <Direction DIR, typename CHAR>
 InternalFormattedIoStatementState<DIR, CHAR>::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<DIR>{d, sourceFile, sourceLine},
-      ioStatementState_{*this}, format_{*this, format, formatLength} {}
+      ioStatementState_{*this}, format_{*this, format, formatLength,
+                                    formatDescriptor} {}
 
 template <Direction DIR, typename CHAR>
 void InternalFormattedIoStatementState<DIR, CHAR>::CompleteOperation() {
   if (!this->completedOperation()) {
     if constexpr (DIR == Direction::Output) {
       format_.Finish(*this); // ignore any remaining input positioning actions
     }
     IoStatementBase::CompleteOperation();
if constexpr (DIR == Direction::Input) {
     Crash("ExternalIoStatementState<Direction::Output>::FinishReadingRecord() "
           "called");
   }
 }
 
 template <Direction DIR, typename CHAR>
 ExternalFormattedIoStatementState<DIR, CHAR>::ExternalFormattedIoStatementState(
     ExternalFileUnit &unit, const CHAR *format, std::size_t formatLength,
-    const char *sourceFile, int sourceLine)
+    const char *sourceFile, int sourceLine, const Descriptor *formatDescriptor)
     : ExternalIoStatementState<DIR>{unit, sourceFile, sourceLine},
-      format_{*this, format, formatLength} {}
+      format_{*this, format, formatLength, formatDescriptor} {}
 
 template <Direction DIR, typename CHAR>
 void ExternalFormattedIoStatementState<DIR, CHAR>::CompleteOperation() {
   if (this->completedOperation()) {
     return;
   }
   if constexpr (DIR == Direction::Input) {
     this->BeginReadingRecord(); // in case there were no I/O items

 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)
+    const char *sourceFile, int sourceLine, const Descriptor *formatDescriptor)
     : ChildIoStatementState<DIR>{child, sourceFile, sourceLine},
       mutableModes_{child.parent().mutableModes()}, format_{*this, format,
-                                                        formatLength} {}
+                                                        formatLength,
+                                                        formatDescriptor} {}
 
 template <Direction DIR, typename CHAR>
 void ChildFormattedIoStatementState<DIR, CHAR>::CompleteOperation() {
   if (!this->completedOperation()) {
     format_.Finish(*this);
     ChildIoStatementState<DIR>::CompleteOperation();
   }
 }

flang/test/Semantics/assign06.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Test ASSIGN statement, assigned GOTO, and assigned format labels
 ! (see subclause 8.2.4 in Fortran 90 (*not* 2018!)
 
 program main
   call test(0)
  contains
   subroutine test(n)
     integer, intent(in) :: n
     integer :: lab
     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
     assign 1 to badlab1
     !ERROR: 'badlab2' must be a default integer scalar variable
     assign 1 to badlab2
     !ERROR: 'badlab3' must be a default integer scalar variable
     assign 1 to badlab3
subroutine test(n)
     write(*,fmt=implicitlab3) ! ok
     !ERROR: Format expression must be default character or default scalar integer
     write(*,fmt=badlab1)
     !ERROR: Format expression must be default character or default scalar integer
     write(*,fmt=z'feedface')
     !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
 end program