llvm-project/flang-rt/lib/runtime/descriptor-io.cpp

//===-- lib/runtime/descriptor-io.cpp ---------------------------*- C++ -*-===//
//
// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
// See https://llvm.org/LICENSE.txt for license information.
// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
//
//===----------------------------------------------------------------------===//

#include "descriptor-io.h"
#include "flang/Common/restorer.h"
#include "flang/Runtime/freestanding-tools.h"

namespace Fortran::runtime::io::descr {
RT_OFFLOAD_API_GROUP_BEGIN

// Defined formatted I/O (maybe)
Fortran::common::optional<bool> DefinedFormattedIo(IoStatementState &io,
    const Descriptor &descriptor, const typeInfo::DerivedType &derived,
    const typeInfo::SpecialBinding &special,
    const SubscriptValue subscripts[]) {
  Fortran::common::optional<DataEdit> peek{
      io.GetNextDataEdit(0 /*to peek at it*/)};
  if (peek &&
      (peek->descriptor == DataEdit::DefinedDerivedType ||
          peek->descriptor == DataEdit::ListDirected)) {
    // Defined formatting
    IoErrorHandler &handler{io.GetIoErrorHandler()};
    DataEdit edit{*io.GetNextDataEdit(1)}; // now consume it; no repeats
    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 {
      runtime::strcpy(
          ioType, io.mutableModes().inNamelist ? "NAMELIST" : "LISTDIRECTED");
      ioTypeLen = runtime::strlen(ioType);
    }
    StaticDescriptor<1, true> vListStatDesc;
    Descriptor &vListDesc{vListStatDesc.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)};
    // Child formatted I/O is nonadvancing by definition (F'2018 12.6.2.4).
    auto restorer{common::ScopedSet(io.mutableModes().nonAdvancing, true)};
    int unit{external->unitNumber()};
    int ioStat{IostatOk};
    char ioMsg[100];
    Fortran::common::optional<std::int64_t> startPos;
    if (edit.descriptor == DataEdit::DefinedDerivedType &&
        special.which() == typeInfo::SpecialBinding::Which::ReadFormatted) {
      // DT is an edit descriptor so everything that the child
      // I/O subroutine reads counts towards READ(SIZE=).
      startPos = io.InquirePos();
    }
    if (special.IsArgDescriptor(0)) {
      // "dtv" argument is "class(t)", pass a descriptor
      auto *p{special.GetProc<void (*)(const Descriptor &, int &, char *,
          const Descriptor &, int &, char *, std::size_t, std::size_t)>()};
      StaticDescriptor<1, true, 10 /*?*/> elementStatDesc;
      Descriptor &elementDesc{elementStatDesc.descriptor()};
      elementDesc.Establish(
          derived, nullptr, 0, nullptr, CFI_attribute_pointer);
      elementDesc.set_base_addr(descriptor.Element<char>(subscripts));
      p(elementDesc, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
          sizeof ioMsg);
    } else {
      // "dtv" argument is "type(t)", pass a raw pointer
      auto *p{special.GetProc<void (*)(const void *, int &, char *,
          const Descriptor &, int &, char *, std::size_t, std::size_t)>()};
      p(descriptor.Element<char>(subscripts), 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();
    }
    if (startPos) {
      io.GotChar(io.InquirePos() - *startPos);
    }
    return handler.GetIoStat() == IostatOk;
  } else {
    // There's a 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 Fortran::common::nullopt;
  }
}

// Defined unformatted I/O
bool DefinedUnformattedIo(IoStatementState &io, const Descriptor &descriptor,
    const typeInfo::DerivedType &derived,
    const typeInfo::SpecialBinding &special) {
  // Unformatted I/O must have an external unit (or child thereof).
  IoErrorHandler &handler{io.GetIoErrorHandler()};
  ExternalFileUnit *external{io.GetExternalFileUnit()};
  if (!external) { // INQUIRE(IOLENGTH=)
    handler.SignalError(IostatNonExternalDefinedUnformattedIo);
    return false;
  }
  ChildIo &child{external->PushChildIo(io)};
  int unit{external->unitNumber()};
  int ioStat{IostatOk};
  char ioMsg[100];
  std::size_t numElements{descriptor.Elements()};
  SubscriptValue subscripts[maxRank];
  descriptor.GetLowerBounds(subscripts);
  if (special.IsArgDescriptor(0)) {
    // "dtv" argument is "class(t)", pass a descriptor
    auto *p{special.GetProc<void (*)(
        const Descriptor &, int &, int &, char *, std::size_t)>()};
    StaticDescriptor<1, true, 10 /*?*/> elementStatDesc;
    Descriptor &elementDesc{elementStatDesc.descriptor()};
    elementDesc.Establish(derived, nullptr, 0, nullptr, CFI_attribute_pointer);
    for (; numElements-- > 0; descriptor.IncrementSubscripts(subscripts)) {
      elementDesc.set_base_addr(descriptor.Element<char>(subscripts));
      p(elementDesc, unit, ioStat, ioMsg, sizeof ioMsg);
      if (ioStat != IostatOk) {
        break;
      }
    }
  } else {
    // "dtv" argument is "type(t)", pass a raw pointer
    auto *p{special.GetProc<void (*)(
        const void *, int &, int &, char *, std::size_t)>()};
    for (; numElements-- > 0; descriptor.IncrementSubscripts(subscripts)) {
      p(descriptor.Element<char>(subscripts), unit, ioStat, ioMsg,
          sizeof ioMsg);
      if (ioStat != IostatOk) {
        break;
      }
    }
  }
  handler.Forward(ioStat, ioMsg, sizeof ioMsg);
  external->PopChildIo(child);
  return handler.GetIoStat() == IostatOk;
}

RT_OFFLOAD_API_GROUP_END
} // namespace Fortran::runtime::io::descr