flang/runtime/descriptor-io.cpp

   1 //===-- runtime/descriptor-io.cpp -----------------------------------------===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "descriptor-io.h"
  10 #include "flang/Common/restorer.h"
  11 #include "flang/Runtime/freestanding-tools.h"
  12
  13 namespace Fortran::runtime::io::descr {
  14 RT_OFFLOAD_API_GROUP_BEGIN
  15
  16 // Defined formatted I/O (maybe)
  17 Fortran::common::optional<bool> DefinedFormattedIo(IoStatementState &io,
  18     const Descriptor &descriptor, const typeInfo::DerivedType &derived,
  19     const typeInfo::SpecialBinding &special,
  20     const SubscriptValue subscripts[]) {
  21   Fortran::common::optional<DataEdit> peek{
  22       io.GetNextDataEdit(0 /*to peek at it*/)};
  23   if (peek &&
  24       (peek->descriptor == DataEdit::DefinedDerivedType ||
  25           peek->descriptor == DataEdit::ListDirected)) {
  26     // Defined formatting
  27     IoErrorHandler &handler{io.GetIoErrorHandler()};
  28     DataEdit edit{*io.GetNextDataEdit(1)}; // now consume it; no repeats
  29     RUNTIME_CHECK(handler, edit.descriptor == peek->descriptor);
  30     char ioType[2 + edit.maxIoTypeChars];
  31     auto ioTypeLen{std::size_t{2} /*"DT"*/ + edit.ioTypeChars};
  32     if (edit.descriptor == DataEdit::DefinedDerivedType) {
  33       ioType[0] = 'D';
  34       ioType[1] = 'T';
  35       std::memcpy(ioType + 2, edit.ioType, edit.ioTypeChars);
  36     } else {
  37       runtime::strcpy(
  38           ioType, io.mutableModes().inNamelist ? "NAMELIST" : "LISTDIRECTED");
  39       ioTypeLen = runtime::strlen(ioType);
  40     }
  41     StaticDescriptor<1, true> vListStatDesc;
  42     Descriptor &vListDesc{vListStatDesc.descriptor()};
  43     vListDesc.Establish(TypeCategory::Integer, sizeof(int), nullptr, 1);
  44     vListDesc.set_base_addr(edit.vList);
  45     vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
  46     vListDesc.GetDimension(0).SetByteStride(
  47         static_cast<SubscriptValue>(sizeof(int)));
  48     ExternalFileUnit *actualExternal{io.GetExternalFileUnit()};
  49     ExternalFileUnit *external{actualExternal};
  50     if (!external) {
  51       // Create a new unit to service defined I/O for an
  52       // internal I/O parent.
  53       external = &ExternalFileUnit::NewUnit(handler, true);
  54     }
  55     ChildIo &child{external->PushChildIo(io)};
  56     // Child formatted I/O is nonadvancing by definition (F'2018 12.6.2.4).
  57     auto restorer{common::ScopedSet(io.mutableModes().nonAdvancing, true)};
  58     int unit{external->unitNumber()};
  59     int ioStat{IostatOk};
  60     char ioMsg[100];
  61     Fortran::common::optional<std::int64_t> startPos;
  62     if (edit.descriptor == DataEdit::DefinedDerivedType &&
  63         special.which() == typeInfo::SpecialBinding::Which::ReadFormatted) {
  64       // DT is an edit descriptor so everything that the child
  65       // I/O subroutine reads counts towards READ(SIZE=).
  66       startPos = io.InquirePos();
  67     }
  68     if (special.IsArgDescriptor(0)) {
  69       // "dtv" argument is "class(t)", pass a descriptor
  70       auto *p{special.GetProc<void (*)(const Descriptor &, int &, char *,
  71           const Descriptor &, int &, char *, std::size_t, std::size_t)>()};
  72       StaticDescriptor<1, true, 10 /*?*/> elementStatDesc;
  73       Descriptor &elementDesc{elementStatDesc.descriptor()};
  74       elementDesc.Establish(
  75           derived, nullptr, 0, nullptr, CFI_attribute_pointer);
  76       elementDesc.set_base_addr(descriptor.Element<char>(subscripts));
  77       p(elementDesc, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
  78           sizeof ioMsg);
  79     } else {
  80       // "dtv" argument is "type(t)", pass a raw pointer
  81       auto *p{special.GetProc<void (*)(const void *, int &, char *,
  82           const Descriptor &, int &, char *, std::size_t, std::size_t)>()};
  83       p(descriptor.Element<char>(subscripts), unit, ioType, vListDesc, ioStat,
  84           ioMsg, ioTypeLen, sizeof ioMsg);
  85     }
  86     handler.Forward(ioStat, ioMsg, sizeof ioMsg);
  87     external->PopChildIo(child);
  88     if (!actualExternal) {
  89       // Close unit created for internal I/O above.
  90       auto *closing{external->LookUpForClose(external->unitNumber())};
  91       RUNTIME_CHECK(handler, external == closing);
  92       external->DestroyClosed();
  93     }
  94     if (startPos) {
  95       io.GotChar(io.InquirePos() - *startPos);
  96     }
  97     return handler.GetIoStat() == IostatOk;
  98   } else {
  99     // There's a defined I/O subroutine, but there's a FORMAT present and
 100     // it does not have a DT data edit descriptor, so apply default formatting
 101     // to the components of the derived type as usual.
 102     return Fortran::common::nullopt;
 103   }
 104 }
 105
 106 // Defined unformatted I/O
 107 bool DefinedUnformattedIo(IoStatementState &io, const Descriptor &descriptor,
 108     const typeInfo::DerivedType &derived,
 109     const typeInfo::SpecialBinding &special) {
 110   // Unformatted I/O must have an external unit (or child thereof).
 111   IoErrorHandler &handler{io.GetIoErrorHandler()};
 112   ExternalFileUnit *external{io.GetExternalFileUnit()};
 113   if (!external) { // INQUIRE(IOLENGTH=)
 114     handler.SignalError(IostatNonExternalDefinedUnformattedIo);
 115     return false;
 116   }
 117   ChildIo &child{external->PushChildIo(io)};
 118   int unit{external->unitNumber()};
 119   int ioStat{IostatOk};
 120   char ioMsg[100];
 121   std::size_t numElements{descriptor.Elements()};
 122   SubscriptValue subscripts[maxRank];
 123   descriptor.GetLowerBounds(subscripts);
 124   if (special.IsArgDescriptor(0)) {
 125     // "dtv" argument is "class(t)", pass a descriptor
 126     auto *p{special.GetProc<void (*)(
 127         const Descriptor &, int &, int &, char *, std::size_t)>()};
 128     StaticDescriptor<1, true, 10 /*?*/> elementStatDesc;
 129     Descriptor &elementDesc{elementStatDesc.descriptor()};
 130     elementDesc.Establish(derived, nullptr, 0, nullptr, CFI_attribute_pointer);
 131     for (; numElements-- > 0; descriptor.IncrementSubscripts(subscripts)) {
 132       elementDesc.set_base_addr(descriptor.Element<char>(subscripts));
 133       p(elementDesc, unit, ioStat, ioMsg, sizeof ioMsg);
 134       if (ioStat != IostatOk) {
 135         break;
 136       }
 137     }
 138   } else {
 139     // "dtv" argument is "type(t)", pass a raw pointer
 140     auto *p{special.GetProc<void (*)(
 141         const void *, int &, int &, char *, std::size_t)>()};
 142     for (; numElements-- > 0; descriptor.IncrementSubscripts(subscripts)) {
 143       p(descriptor.Element<char>(subscripts), unit, ioStat, ioMsg,
 144           sizeof ioMsg);
 145       if (ioStat != IostatOk) {
 146         break;
 147       }
 148     }
 149   }
 150   handler.Forward(ioStat, ioMsg, sizeof ioMsg);
 151   external->PopChildIo(child);
 152   return handler.GetIoStat() == IostatOk;
 153 }
 154
 155 RT_OFFLOAD_API_GROUP_END
 156 } // namespace Fortran::runtime::io::descr