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 "edit-input.h"
11#include "edit-output.h"
12#include "unit.h"
13#include "flang-rt/runtime/descriptor.h"
14#include "flang-rt/runtime/io-stmt.h"
15#include "flang-rt/runtime/namelist.h"
16#include "flang-rt/runtime/terminator.h"
17#include "flang-rt/runtime/type-info.h"
18#include "flang-rt/runtime/work-queue.h"
19#include "flang/Common/optional.h"
20#include "flang/Common/restorer.h"
21#include "flang/Common/uint128.h"
22#include "flang/Runtime/cpp-type.h"
23#include "flang/Runtime/freestanding-tools.h"
24
25// Implementation of I/O data list item transfers based on descriptors.
26// (All I/O items come through here so that the code is exercised for test;
27// some scalar I/O data transfer APIs could be changed to bypass their use
28// of descriptors in the future for better efficiency.)
29
30namespace Fortran::runtime::io::descr {
31RT_OFFLOAD_API_GROUP_BEGIN
32
33template <typename A>
34inline RT_API_ATTRS A &ExtractElement(IoStatementState &io,
35 const Descriptor &descriptor, const SubscriptValue subscripts[]) {
36 A *p{descriptor.Element<A>(subscripts)};
37 if (!p) {
38 io.GetIoErrorHandler().Crash("Bad address for I/O item -- null base "
39 "address or subscripts out of range");
40 }
41 return *p;
42}
43
44// Defined formatted I/O (maybe)
45static RT_API_ATTRS Fortran::common::optional<bool> DefinedFormattedIo(
46 IoStatementState &io, const Descriptor &descriptor,
47 const typeInfo::DerivedType &derived,
48 const typeInfo::SpecialBinding &special,
49 const SubscriptValue subscripts[]) {
50 Fortran::common::optional<DataEdit> peek{
51 io.GetNextDataEdit(0 /*to peek at it*/)};
52 if (peek &&
53 (peek->descriptor == DataEdit::DefinedDerivedType ||
54 peek->descriptor == DataEdit::ListDirected)) {
55 // Defined formatting
56 IoErrorHandler &handler{io.GetIoErrorHandler()};
57 DataEdit edit{*io.GetNextDataEdit(1)}; // now consume it; no repeats
58 RUNTIME_CHECK(handler, edit.descriptor == peek->descriptor);
59 char ioType[2 + edit.maxIoTypeChars];
60 auto ioTypeLen{std::size_t{2} /*"DT"*/ + edit.ioTypeChars};
61 if (edit.descriptor == DataEdit::DefinedDerivedType) {
62 ioType[0] = 'D';
63 ioType[1] = 'T';
64 std::memcpy(ioType + 2, edit.ioType, edit.ioTypeChars);
65 } else {
66 runtime::strcpy(
67 ioType, io.mutableModes().inNamelist ? "NAMELIST" : "LISTDIRECTED");
68 ioTypeLen = runtime::strlen(ioType);
69 }
70 StaticDescriptor<1, true> vListStatDesc;
71 Descriptor &vListDesc{vListStatDesc.descriptor()};
72 vListDesc.Establish(TypeCategory::Integer, sizeof(int), nullptr, 1);
73 vListDesc.set_base_addr(edit.vList);
74 vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
75 vListDesc.GetDimension(0).SetByteStride(
76 static_cast<SubscriptValue>(sizeof(int)));
77 ExternalFileUnit *actualExternal{io.GetExternalFileUnit()};
78 ExternalFileUnit *external{actualExternal};
79 if (!external) {
80 // Create a new unit to service defined I/O for an
81 // internal I/O parent.
82 external = &ExternalFileUnit::NewUnit(handler, true);
83 }
84 ChildIo &child{external->PushChildIo(io)};
85 // Child formatted I/O is nonadvancing by definition (F'2018 12.6.2.4).
86 auto restorer{common::ScopedSet(io.mutableModes().nonAdvancing, true)};
87 int unit{external->unitNumber()};
88 int ioStat{IostatOk};
89 char ioMsg[100];
90 Fortran::common::optional<std::int64_t> startPos;
91 if (edit.descriptor == DataEdit::DefinedDerivedType &&
92 special.which() == typeInfo::SpecialBinding::Which::ReadFormatted) {
93 // DT is an edit descriptor so everything that the child
94 // I/O subroutine reads counts towards READ(SIZE=).
95 startPos = io.InquirePos();
96 }
97 const auto *bindings{
98 derived.binding().OffsetElement<const typeInfo::Binding>()};
99 if (special.IsArgDescriptor(0)) {
100 // "dtv" argument is "class(t)", pass a descriptor
101 auto *p{special.GetProc<void (*)(const Descriptor &, int &, char *,
102 const Descriptor &, int &, char *, std::size_t, std::size_t)>(
103 bindings)};
104 StaticDescriptor<1, true, 10 /*?*/> elementStatDesc;
105 Descriptor &elementDesc{elementStatDesc.descriptor()};
106 elementDesc.Establish(
107 derived, nullptr, 0, nullptr, CFI_attribute_pointer);
108 elementDesc.set_base_addr(descriptor.Element<char>(subscripts));
109 p(elementDesc, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
110 sizeof ioMsg);
111 } else {
112 // "dtv" argument is "type(t)", pass a raw pointer
113 auto *p{special.GetProc<void (*)(const void *, int &, char *,
114 const Descriptor &, int &, char *, std::size_t, std::size_t)>(
115 bindings)};
116 p(descriptor.Element<char>(subscripts), unit, ioType, vListDesc, ioStat,
117 ioMsg, ioTypeLen, sizeof ioMsg);
118 }
119 handler.Forward(ioStat, ioMsg, sizeof ioMsg);
120 external->PopChildIo(child);
121 if (!actualExternal) {
122 // Close unit created for internal I/O above.
123 auto *closing{external->LookUpForClose(external->unitNumber())};
124 RUNTIME_CHECK(handler, external == closing);
125 external->DestroyClosed();
126 }
127 if (startPos) {
128 io.GotChar(io.InquirePos() - *startPos);
129 }
130 return handler.GetIoStat() == IostatOk;
131 } else {
132 // There's a defined I/O subroutine, but there's a FORMAT present and
133 // it does not have a DT data edit descriptor, so apply default formatting
134 // to the components of the derived type as usual.
135 return Fortran::common::nullopt;
136 }
137}
138
139// Defined unformatted I/O
140static RT_API_ATTRS bool DefinedUnformattedIo(IoStatementState &io,
141 const Descriptor &descriptor, const typeInfo::DerivedType &derived,
142 const typeInfo::SpecialBinding &special) {
143 // Unformatted I/O must have an external unit (or child thereof).
144 IoErrorHandler &handler{io.GetIoErrorHandler()};
145 ExternalFileUnit *external{io.GetExternalFileUnit()};
146 if (!external) { // INQUIRE(IOLENGTH=)
147 handler.SignalError(IostatNonExternalDefinedUnformattedIo);
148 return false;
149 }
150 ChildIo &child{external->PushChildIo(io)};
151 int unit{external->unitNumber()};
152 int ioStat{IostatOk};
153 char ioMsg[100];
154 std::size_t numElements{descriptor.Elements()};
155 SubscriptValue subscripts[maxRank];
156 descriptor.GetLowerBounds(subscripts);
157 const auto *bindings{
158 derived.binding().OffsetElement<const typeInfo::Binding>()};
159 if (special.IsArgDescriptor(0)) {
160 // "dtv" argument is "class(t)", pass a descriptor
161 auto *p{special.GetProc<void (*)(
162 const Descriptor &, int &, int &, char *, std::size_t)>(bindings)};
163 StaticDescriptor<1, true, 10 /*?*/> elementStatDesc;
164 Descriptor &elementDesc{elementStatDesc.descriptor()};
165 elementDesc.Establish(derived, nullptr, 0, nullptr, CFI_attribute_pointer);
166 for (; numElements-- > 0; descriptor.IncrementSubscripts(subscripts)) {
167 elementDesc.set_base_addr(descriptor.Element<char>(subscripts));
168 p(elementDesc, unit, ioStat, ioMsg, sizeof ioMsg);
169 if (ioStat != IostatOk) {
170 break;
171 }
172 }
173 } else {
174 // "dtv" argument is "type(t)", pass a raw pointer
175 auto *p{special
176 .GetProc<void (*)(const void *, int &, int &, char *, std::size_t)>(
177 bindings)};
178 for (; numElements-- > 0; descriptor.IncrementSubscripts(subscripts)) {
179 p(descriptor.Element<char>(subscripts), unit, ioStat, ioMsg,
180 sizeof ioMsg);
181 if (ioStat != IostatOk) {
182 break;
183 }
184 }
185 }
186 handler.Forward(ioStat, ioMsg, sizeof ioMsg);
187 external->PopChildIo(child);
188 return handler.GetIoStat() == IostatOk;
189}
190
191// Per-category descriptor-based I/O templates
192
193// TODO (perhaps as a nontrivial but small starter project): implement
194// automatic repetition counts, like "10*3.14159", for list-directed and
195// NAMELIST array output.
196
197template <int KIND, Direction DIR>
198inline RT_API_ATTRS bool FormattedIntegerIO(IoStatementState &io,
199 const Descriptor &descriptor, [[maybe_unused]] bool isSigned) {
200 std::size_t numElements{descriptor.Elements()};
201 SubscriptValue subscripts[maxRank];
202 descriptor.GetLowerBounds(subscripts);
203 using IntType = CppTypeFor<common::TypeCategory::Integer, KIND>;
204 bool anyInput{false};
205 for (std::size_t j{0}; j < numElements; ++j) {
206 if (auto edit{io.GetNextDataEdit()}) {
207 IntType &x{ExtractElement<IntType>(io, descriptor, subscripts)};
208 if constexpr (DIR == Direction::Output) {
209 if (!EditIntegerOutput<KIND>(io, *edit, x, isSigned)) {
210 return false;
211 }
212 } else if (edit->descriptor != DataEdit::ListDirectedNullValue) {
213 if (EditIntegerInput(
214 io, *edit, reinterpret_cast<void *>(&x), KIND, isSigned)) {
215 anyInput = true;
216 } else {
217 return anyInput && edit->IsNamelist();
218 }
219 }
220 if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
221 io.GetIoErrorHandler().Crash(
222 "FormattedIntegerIO: subscripts out of bounds");
223 }
224 } else {
225 return false;
226 }
227 }
228 return true;
229}
230
231template <int KIND, Direction DIR>
232inline RT_API_ATTRS bool FormattedRealIO(
233 IoStatementState &io, const Descriptor &descriptor) {
234 std::size_t numElements{descriptor.Elements()};
235 SubscriptValue subscripts[maxRank];
236 descriptor.GetLowerBounds(subscripts);
237 using RawType = typename RealOutputEditing<KIND>::BinaryFloatingPoint;
238 bool anyInput{false};
239 for (std::size_t j{0}; j < numElements; ++j) {
240 if (auto edit{io.GetNextDataEdit()}) {
241 RawType &x{ExtractElement<RawType>(io, descriptor, subscripts)};
242 if constexpr (DIR == Direction::Output) {
243 if (!RealOutputEditing<KIND>{io, x}.Edit(*edit)) {
244 return false;
245 }
246 } else if (edit->descriptor != DataEdit::ListDirectedNullValue) {
247 if (EditRealInput<KIND>(io, *edit, reinterpret_cast<void *>(&x))) {
248 anyInput = true;
249 } else {
250 return anyInput && edit->IsNamelist();
251 }
252 }
253 if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
254 io.GetIoErrorHandler().Crash(
255 "FormattedRealIO: subscripts out of bounds");
256 }
257 } else {
258 return false;
259 }
260 }
261 return true;
262}
263
264template <int KIND, Direction DIR>
265inline RT_API_ATTRS bool FormattedComplexIO(
266 IoStatementState &io, const Descriptor &descriptor) {
267 std::size_t numElements{descriptor.Elements()};
268 SubscriptValue subscripts[maxRank];
269 descriptor.GetLowerBounds(subscripts);
270 bool isListOutput{
271 io.get_if<ListDirectedStatementState<Direction::Output>>() != nullptr};
272 using RawType = typename RealOutputEditing<KIND>::BinaryFloatingPoint;
273 bool anyInput{false};
274 for (std::size_t j{0}; j < numElements; ++j) {
275 RawType *x{&ExtractElement<RawType>(io, descriptor, subscripts)};
276 if (isListOutput) {
277 DataEdit rEdit, iEdit;
278 rEdit.descriptor = DataEdit::ListDirectedRealPart;
279 iEdit.descriptor = DataEdit::ListDirectedImaginaryPart;
280 rEdit.modes = iEdit.modes = io.mutableModes();
281 if (!RealOutputEditing<KIND>{io, x[0]}.Edit(rEdit) ||
282 !RealOutputEditing<KIND>{io, x[1]}.Edit(iEdit)) {
283 return false;
284 }
285 } else {
286 for (int k{0}; k < 2; ++k, ++x) {
287 auto edit{io.GetNextDataEdit()};
288 if (!edit) {
289 return false;
290 } else if constexpr (DIR == Direction::Output) {
291 if (!RealOutputEditing<KIND>{io, *x}.Edit(*edit)) {
292 return false;
293 }
294 } else if (edit->descriptor == DataEdit::ListDirectedNullValue) {
295 break;
296 } else if (EditRealInput<KIND>(
297 io, *edit, reinterpret_cast<void *>(x))) {
298 anyInput = true;
299 } else {
300 return anyInput && edit->IsNamelist();
301 }
302 }
303 }
304 if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
305 io.GetIoErrorHandler().Crash(
306 "FormattedComplexIO: subscripts out of bounds");
307 }
308 }
309 return true;
310}
311
312template <typename A, Direction DIR>
313inline RT_API_ATTRS bool FormattedCharacterIO(
314 IoStatementState &io, const Descriptor &descriptor) {
315 std::size_t numElements{descriptor.Elements()};
316 SubscriptValue subscripts[maxRank];
317 descriptor.GetLowerBounds(subscripts);
318 std::size_t length{descriptor.ElementBytes() / sizeof(A)};
319 auto *listOutput{io.get_if<ListDirectedStatementState<Direction::Output>>()};
320 bool anyInput{false};
321 for (std::size_t j{0}; j < numElements; ++j) {
322 A *x{&ExtractElement<A>(io, descriptor, subscripts)};
323 if (listOutput) {
324 if (!ListDirectedCharacterOutput(io, *listOutput, x, length)) {
325 return false;
326 }
327 } else if (auto edit{io.GetNextDataEdit()}) {
328 if constexpr (DIR == Direction::Output) {
329 if (!EditCharacterOutput(io, *edit, x, length)) {
330 return false;
331 }
332 } else { // input
333 if (edit->descriptor != DataEdit::ListDirectedNullValue) {
334 if (EditCharacterInput(io, *edit, x, length)) {
335 anyInput = true;
336 } else {
337 return anyInput && edit->IsNamelist();
338 }
339 }
340 }
341 } else {
342 return false;
343 }
344 if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
345 io.GetIoErrorHandler().Crash(
346 "FormattedCharacterIO: subscripts out of bounds");
347 }
348 }
349 return true;
350}
351
352template <int KIND, Direction DIR>
353inline RT_API_ATTRS bool FormattedLogicalIO(
354 IoStatementState &io, const Descriptor &descriptor) {
355 std::size_t numElements{descriptor.Elements()};
356 SubscriptValue subscripts[maxRank];
357 descriptor.GetLowerBounds(subscripts);
358 auto *listOutput{io.get_if<ListDirectedStatementState<Direction::Output>>()};
359 using IntType = CppTypeFor<TypeCategory::Integer, KIND>;
360 bool anyInput{false};
361 for (std::size_t j{0}; j < numElements; ++j) {
362 IntType &x{ExtractElement<IntType>(io, descriptor, subscripts)};
363 if (listOutput) {
364 if (!ListDirectedLogicalOutput(io, *listOutput, x != 0)) {
365 return false;
366 }
367 } else if (auto edit{io.GetNextDataEdit()}) {
368 if constexpr (DIR == Direction::Output) {
369 if (!EditLogicalOutput(io, *edit, x != 0)) {
370 return false;
371 }
372 } else {
373 if (edit->descriptor != DataEdit::ListDirectedNullValue) {
374 bool truth{};
375 if (EditLogicalInput(io, *edit, truth)) {
376 x = truth;
377 anyInput = true;
378 } else {
379 return anyInput && edit->IsNamelist();
380 }
381 }
382 }
383 } else {
384 return false;
385 }
386 if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
387 io.GetIoErrorHandler().Crash(
388 "FormattedLogicalIO: subscripts out of bounds");
389 }
390 }
391 return true;
392}
393
394template <Direction DIR>
395RT_API_ATTRS int DerivedIoTicket<DIR>::Continue(WorkQueue &workQueue) {
396 while (!IsComplete()) {
397 if (component_->genre() == typeInfo::Component::Genre::Data) {
398 // Create a descriptor for the component
399 Descriptor &compDesc{componentDescriptor_.descriptor()};
400 component_->CreatePointerDescriptor(
401 compDesc, instance_, io_.GetIoErrorHandler(), subscripts_);
402 Advance();
403 if (int status{workQueue.BeginDescriptorIo<DIR>(
404 io_, compDesc, table_, anyIoTookPlace_)};
405 status != StatOk) {
406 return status;
407 }
408 } else {
409 // Component is itself a descriptor
410 char *pointer{
411 instance_.Element<char>(subscripts_) + component_->offset()};
412 const Descriptor &compDesc{
413 *reinterpret_cast<const Descriptor *>(pointer)};
414 Advance();
415 if (compDesc.IsAllocated()) {
416 if (int status{workQueue.BeginDescriptorIo<DIR>(
417 io_, compDesc, table_, anyIoTookPlace_)};
418 status != StatOk) {
419 return status;
420 }
421 }
422 }
423 }
424 return StatOk;
425}
426
427template RT_API_ATTRS int DerivedIoTicket<Direction::Output>::Continue(
428 WorkQueue &);
429template RT_API_ATTRS int DerivedIoTicket<Direction::Input>::Continue(
430 WorkQueue &);
431
432template <Direction DIR>
433RT_API_ATTRS int DescriptorIoTicket<DIR>::Begin(WorkQueue &workQueue) {
434 IoErrorHandler &handler{io_.GetIoErrorHandler()};
435 if (handler.InError()) {
436 return handler.GetIoStat();
437 }
438 if (!io_.get_if<IoDirectionState<DIR>>()) {
439 handler.Crash("DescriptorIO() called for wrong I/O direction");
440 return handler.GetIoStat();
441 }
442 if constexpr (DIR == Direction::Input) {
443 if (!io_.BeginReadingRecord()) {
444 return StatOk;
445 }
446 }
447 if (!io_.get_if<FormattedIoStatementState<DIR>>()) {
448 // Unformatted I/O
449 IoErrorHandler &handler{io_.GetIoErrorHandler()};
450 const DescriptorAddendum *addendum{instance_.Addendum()};
451 if (const typeInfo::DerivedType *type{
452 addendum ? addendum->derivedType() : nullptr}) {
453 // derived type unformatted I/O
454 if (DIR == Direction::Input || !io_.get_if<InquireIOLengthState>()) {
455 if (table_) {
456 if (const auto *definedIo{table_->Find(*type,
457 DIR == Direction::Input
458 ? common::DefinedIo::ReadUnformatted
459 : common::DefinedIo::WriteUnformatted)}) {
460 if (definedIo->subroutine) {
461 typeInfo::SpecialBinding special{DIR == Direction::Input
462 ? typeInfo::SpecialBinding::Which::ReadUnformatted
463 : typeInfo::SpecialBinding::Which::WriteUnformatted,
464 definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
465 false};
466 if (DefinedUnformattedIo(io_, instance_, *type, special)) {
467 anyIoTookPlace_ = true;
468 return StatOk;
469 }
470 } else {
471 int status{workQueue.BeginDerivedIo<DIR>(
472 io_, instance_, *type, table_, anyIoTookPlace_)};
473 return status == StatContinue ? StatOk : status; // done here
474 }
475 }
476 }
477 if (const typeInfo::SpecialBinding *special{
478 type->FindSpecialBinding(DIR == Direction::Input
479 ? typeInfo::SpecialBinding::Which::ReadUnformatted
480 : typeInfo::SpecialBinding::Which::WriteUnformatted)}) {
481 if (!table_ || !table_->ignoreNonTbpEntries ||
482 special->IsTypeBound()) {
483 // defined derived type unformatted I/O
484 if (DefinedUnformattedIo(io_, instance_, *type, *special)) {
485 anyIoTookPlace_ = true;
486 return StatOk;
487 } else {
488 return IostatEnd;
489 }
490 }
491 }
492 }
493 // Default derived type unformatted I/O
494 // TODO: If no component at any level has defined READ or WRITE
495 // (as appropriate), the elements are contiguous, and no byte swapping
496 // is active, do a block transfer via the code below.
497 int status{workQueue.BeginDerivedIo<DIR>(
498 io_, instance_, *type, table_, anyIoTookPlace_)};
499 return status == StatContinue ? StatOk : status; // done here
500 } else {
501 // intrinsic type unformatted I/O
502 auto *externalUnf{io_.get_if<ExternalUnformattedIoStatementState<DIR>>()};
503 ChildUnformattedIoStatementState<DIR> *childUnf{nullptr};
504 InquireIOLengthState *inq{nullptr};
505 bool swapEndianness{false};
506 if (externalUnf) {
507 swapEndianness = externalUnf->unit().swapEndianness();
508 } else {
509 childUnf = io_.get_if<ChildUnformattedIoStatementState<DIR>>();
510 if (!childUnf) {
511 inq = DIR == Direction::Output ? io_.get_if<InquireIOLengthState>()
512 : nullptr;
513 RUNTIME_CHECK(handler, inq != nullptr);
514 }
515 }
516 std::size_t elementBytes{instance_.ElementBytes()};
517 std::size_t swappingBytes{elementBytes};
518 if (auto maybeCatAndKind{instance_.type().GetCategoryAndKind()}) {
519 // Byte swapping units can be smaller than elements, namely
520 // for COMPLEX and CHARACTER.
521 if (maybeCatAndKind->first == TypeCategory::Character) {
522 // swap each character position independently
523 swappingBytes = maybeCatAndKind->second; // kind
524 } else if (maybeCatAndKind->first == TypeCategory::Complex) {
525 // swap real and imaginary components independently
526 swappingBytes /= 2;
527 }
528 }
529 using CharType =
530 std::conditional_t<DIR == Direction::Output, const char, char>;
531 auto Transfer{[=](CharType &x, std::size_t totalBytes) -> bool {
532 if constexpr (DIR == Direction::Output) {
533 return externalUnf ? externalUnf->Emit(&x, totalBytes, swappingBytes)
534 : childUnf ? childUnf->Emit(&x, totalBytes, swappingBytes)
535 : inq->Emit(&x, totalBytes, swappingBytes);
536 } else {
537 return externalUnf
538 ? externalUnf->Receive(&x, totalBytes, swappingBytes)
539 : childUnf->Receive(&x, totalBytes, swappingBytes);
540 }
541 }};
542 if (!swapEndianness &&
543 instance_.IsContiguous()) { // contiguous unformatted I/O
544 char &x{ExtractElement<char>(io_, instance_, subscripts_)};
545 if (Transfer(x, elements_ * elementBytes)) {
546 anyIoTookPlace_ = true;
547 } else {
548 return IostatEnd;
549 }
550 } else { // non-contiguous or byte-swapped intrinsic type unformatted I/O
551 for (; !IsComplete(); Advance()) {
552 char &x{ExtractElement<char>(io_, instance_, subscripts_)};
553 if (Transfer(x, elementBytes)) {
554 anyIoTookPlace_ = true;
555 } else {
556 return IostatEnd;
557 }
558 }
559 }
560 }
561 // Unformatted I/O never needs to call Continue().
562 return StatOk;
563 }
564 // Formatted I/O
565 if (auto catAndKind{instance_.type().GetCategoryAndKind()}) {
566 TypeCategory cat{catAndKind->first};
567 int kind{catAndKind->second};
568 bool any{false};
569 switch (cat) {
570 case TypeCategory::Integer:
571 switch (kind) {
572 case 1:
573 any = FormattedIntegerIO<1, DIR>(io_, instance_, true);
574 break;
575 case 2:
576 any = FormattedIntegerIO<2, DIR>(io_, instance_, true);
577 break;
578 case 4:
579 any = FormattedIntegerIO<4, DIR>(io_, instance_, true);
580 break;
581 case 8:
582 any = FormattedIntegerIO<8, DIR>(io_, instance_, true);
583 break;
584 case 16:
585 any = FormattedIntegerIO<16, DIR>(io_, instance_, true);
586 break;
587 default:
588 handler.Crash(
589 "not yet implemented: INTEGER(KIND=%d) in formatted IO", kind);
590 return IostatEnd;
591 }
592 break;
593 case TypeCategory::Unsigned:
594 switch (kind) {
595 case 1:
596 any = FormattedIntegerIO<1, DIR>(io_, instance_, false);
597 break;
598 case 2:
599 any = FormattedIntegerIO<2, DIR>(io_, instance_, false);
600 break;
601 case 4:
602 any = FormattedIntegerIO<4, DIR>(io_, instance_, false);
603 break;
604 case 8:
605 any = FormattedIntegerIO<8, DIR>(io_, instance_, false);
606 break;
607 case 16:
608 any = FormattedIntegerIO<16, DIR>(io_, instance_, false);
609 break;
610 default:
611 handler.Crash(
612 "not yet implemented: UNSIGNED(KIND=%d) in formatted IO", kind);
613 return IostatEnd;
614 }
615 break;
616 case TypeCategory::Real:
617 switch (kind) {
618 case 2:
619 any = FormattedRealIO<2, DIR>(io_, instance_);
620 break;
621 case 3:
622 any = FormattedRealIO<3, DIR>(io_, instance_);
623 break;
624 case 4:
625 any = FormattedRealIO<4, DIR>(io_, instance_);
626 break;
627 case 8:
628 any = FormattedRealIO<8, DIR>(io_, instance_);
629 break;
630 case 10:
631 any = FormattedRealIO<10, DIR>(io_, instance_);
632 break;
633 // TODO: case double/double
634 case 16:
635 any = FormattedRealIO<16, DIR>(io_, instance_);
636 break;
637 default:
638 handler.Crash(
639 "not yet implemented: REAL(KIND=%d) in formatted IO", kind);
640 return IostatEnd;
641 }
642 break;
643 case TypeCategory::Complex:
644 switch (kind) {
645 case 2:
646 any = FormattedComplexIO<2, DIR>(io_, instance_);
647 break;
648 case 3:
649 any = FormattedComplexIO<3, DIR>(io_, instance_);
650 break;
651 case 4:
652 any = FormattedComplexIO<4, DIR>(io_, instance_);
653 break;
654 case 8:
655 any = FormattedComplexIO<8, DIR>(io_, instance_);
656 break;
657 case 10:
658 any = FormattedComplexIO<10, DIR>(io_, instance_);
659 break;
660 // TODO: case double/double
661 case 16:
662 any = FormattedComplexIO<16, DIR>(io_, instance_);
663 break;
664 default:
665 handler.Crash(
666 "not yet implemented: COMPLEX(KIND=%d) in formatted IO", kind);
667 return IostatEnd;
668 }
669 break;
670 case TypeCategory::Character:
671 switch (kind) {
672 case 1:
673 any = FormattedCharacterIO<char, DIR>(io_, instance_);
674 break;
675 case 2:
676 any = FormattedCharacterIO<char16_t, DIR>(io_, instance_);
677 break;
678 case 4:
679 any = FormattedCharacterIO<char32_t, DIR>(io_, instance_);
680 break;
681 default:
682 handler.Crash(
683 "not yet implemented: CHARACTER(KIND=%d) in formatted IO", kind);
684 return IostatEnd;
685 }
686 break;
687 case TypeCategory::Logical:
688 switch (kind) {
689 case 1:
690 any = FormattedLogicalIO<1, DIR>(io_, instance_);
691 break;
692 case 2:
693 any = FormattedLogicalIO<2, DIR>(io_, instance_);
694 break;
695 case 4:
696 any = FormattedLogicalIO<4, DIR>(io_, instance_);
697 break;
698 case 8:
699 any = FormattedLogicalIO<8, DIR>(io_, instance_);
700 break;
701 default:
702 handler.Crash(
703 "not yet implemented: LOGICAL(KIND=%d) in formatted IO", kind);
704 return IostatEnd;
705 }
706 break;
707 case TypeCategory::Derived: {
708 // Derived type information must be present for formatted I/O.
709 IoErrorHandler &handler{io_.GetIoErrorHandler()};
710 const DescriptorAddendum *addendum{instance_.Addendum()};
711 RUNTIME_CHECK(handler, addendum != nullptr);
712 derived_ = addendum->derivedType();
713 RUNTIME_CHECK(handler, derived_ != nullptr);
714 if (table_) {
715 if (const auto *definedIo{table_->Find(*derived_,
716 DIR == Direction::Input ? common::DefinedIo::ReadFormatted
717 : common::DefinedIo::WriteFormatted)}) {
718 if (definedIo->subroutine) {
719 nonTbpSpecial_.emplace(DIR == Direction::Input
720 ? typeInfo::SpecialBinding::Which::ReadFormatted
721 : typeInfo::SpecialBinding::Which::WriteFormatted,
722 definedIo->subroutine, definedIo->isDtvArgPolymorphic, false,
723 false);
724 special_ = &*nonTbpSpecial_;
725 }
726 }
727 }
728 if (!special_) {
729 if (const typeInfo::SpecialBinding *binding{
730 derived_->FindSpecialBinding(DIR == Direction::Input
731 ? typeInfo::SpecialBinding::Which::ReadFormatted
732 : typeInfo::SpecialBinding::Which::WriteFormatted)}) {
733 if (!table_ || !table_->ignoreNonTbpEntries ||
734 binding->IsTypeBound()) {
735 special_ = binding;
736 }
737 }
738 }
739 return StatContinue;
740 }
741 }
742 if (any) {
743 anyIoTookPlace_ = true;
744 } else {
745 return IostatEnd;
746 }
747 } else {
748 handler.Crash("DescriptorIO: bad type code (%d) in descriptor",
749 static_cast<int>(instance_.type().raw()));
750 return handler.GetIoStat();
751 }
752 return StatOk;
753}
754
755template RT_API_ATTRS int DescriptorIoTicket<Direction::Output>::Begin(
756 WorkQueue &);
757template RT_API_ATTRS int DescriptorIoTicket<Direction::Input>::Begin(
758 WorkQueue &);
759
760template <Direction DIR>
761RT_API_ATTRS int DescriptorIoTicket<DIR>::Continue(WorkQueue &workQueue) {
762 // Only derived type formatted I/O gets here.
763 while (!IsComplete()) {
764 if (special_) {
765 if (auto defined{DefinedFormattedIo(
766 io_, instance_, *derived_, *special_, subscripts_)}) {
767 anyIoTookPlace_ |= *defined;
768 Advance();
769 continue;
770 }
771 }
772 Descriptor &elementDesc{elementDescriptor_.descriptor()};
773 elementDesc.Establish(
774 *derived_, nullptr, 0, nullptr, CFI_attribute_pointer);
775 elementDesc.set_base_addr(instance_.Element<char>(subscripts_));
776 Advance();
777 if (int status{workQueue.BeginDerivedIo<DIR>(
778 io_, elementDesc, *derived_, table_, anyIoTookPlace_)};
779 status != StatOk) {
780 return status;
781 }
782 }
783 return StatOk;
784}
785
786template RT_API_ATTRS int DescriptorIoTicket<Direction::Output>::Continue(
787 WorkQueue &);
788template RT_API_ATTRS int DescriptorIoTicket<Direction::Input>::Continue(
789 WorkQueue &);
790
791template <Direction DIR>
792RT_API_ATTRS bool DescriptorIO(IoStatementState &io,
793 const Descriptor &descriptor, const NonTbpDefinedIoTable *table) {
794 bool anyIoTookPlace{false};
795 WorkQueue workQueue{io.GetIoErrorHandler()};
796 if (workQueue.BeginDescriptorIo<DIR>(io, descriptor, table, anyIoTookPlace) ==
797 StatContinue) {
798 workQueue.Run();
799 }
800 return anyIoTookPlace;
801}
802
803template RT_API_ATTRS bool DescriptorIO<Direction::Output>(
804 IoStatementState &, const Descriptor &, const NonTbpDefinedIoTable *);
805template RT_API_ATTRS bool DescriptorIO<Direction::Input>(
806 IoStatementState &, const Descriptor &, const NonTbpDefinedIoTable *);
807
808RT_OFFLOAD_API_GROUP_END
809} // namespace Fortran::runtime::io::descr
810

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