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

source code of flang/runtime/descriptor-io.cpp