llvm-project

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
157