1//===-- lib/runtime/descriptor-io.cpp ---------------------------*- C++ -*-===//
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
13namespace Fortran::runtime::io::descr {
14RT_OFFLOAD_API_GROUP_BEGIN
15
16// Defined formatted I/O (maybe)
17Fortran::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
107bool 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
155RT_OFFLOAD_API_GROUP_END
156} // namespace Fortran::runtime::io::descr
157

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