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
11 namespace Fortran::runtime::io::descr {
12
13 // User-defined derived type formatted I/O (maybe)
DefinedFormattedIo(IoStatementState & io,const Descriptor & descriptor,const typeInfo::SpecialBinding & special)14 std::optional<bool> DefinedFormattedIo(IoStatementState &io,
15 const Descriptor &descriptor, const typeInfo::SpecialBinding &special) {
16 std::optional<DataEdit> peek{io.GetNextDataEdit(0 /*to peek at it*/)};
17 if (peek &&
18 (peek->descriptor == DataEdit::DefinedDerivedType ||
19 peek->descriptor == DataEdit::ListDirected)) {
20 // User-defined derived type formatting
21 IoErrorHandler &handler{io.GetIoErrorHandler()};
22 DataEdit edit{*io.GetNextDataEdit()}; // consume it this time
23 RUNTIME_CHECK(handler, edit.descriptor == peek->descriptor);
24 char ioType[2 + edit.maxIoTypeChars];
25 auto ioTypeLen{std::size_t{2} /*"DT"*/ + edit.ioTypeChars};
26 if (edit.descriptor == DataEdit::DefinedDerivedType) {
27 ioType[0] = 'D';
28 ioType[1] = 'T';
29 std::memcpy(ioType + 2, edit.ioType, edit.ioTypeChars);
30 } else {
31 std::strcpy(
32 ioType, io.mutableModes().inNamelist ? "NAMELIST" : "LISTDIRECTED");
33 ioTypeLen = std::strlen(ioType);
34 }
35 StaticDescriptor<1, true> statDesc;
36 Descriptor &vListDesc{statDesc.descriptor()};
37 vListDesc.Establish(TypeCategory::Integer, sizeof(int), nullptr, 1);
38 vListDesc.set_base_addr(edit.vList);
39 vListDesc.GetDimension(0).SetBounds(1, edit.vListEntries);
40 vListDesc.GetDimension(0).SetByteStride(
41 static_cast<SubscriptValue>(sizeof(int)));
42 ExternalFileUnit *actualExternal{io.GetExternalFileUnit()};
43 ExternalFileUnit *external{actualExternal};
44 if (!external) {
45 // Create a new unit to service defined I/O for an
46 // internal I/O parent.
47 external = &ExternalFileUnit::NewUnit(handler, true);
48 }
49 ChildIo &child{external->PushChildIo(io)};
50 int unit{external->unitNumber()};
51 int ioStat{IostatOk};
52 char ioMsg[100];
53 if (special.IsArgDescriptor(0)) {
54 auto *p{special.GetProc<void (*)(const Descriptor &, int &, char *,
55 const Descriptor &, int &, char *, std::size_t, std::size_t)>()};
56 p(descriptor, unit, ioType, vListDesc, ioStat, ioMsg, ioTypeLen,
57 sizeof ioMsg);
58 } else {
59 auto *p{special.GetProc<void (*)(const void *, int &, char *,
60 const Descriptor &, int &, char *, std::size_t, std::size_t)>()};
61 p(descriptor.raw().base_addr, unit, ioType, vListDesc, ioStat, ioMsg,
62 ioTypeLen, sizeof ioMsg);
63 }
64 handler.Forward(ioStat, ioMsg, sizeof ioMsg);
65 external->PopChildIo(child);
66 if (!actualExternal) {
67 // Close unit created for internal I/O above.
68 auto *closing{external->LookUpForClose(external->unitNumber())};
69 RUNTIME_CHECK(handler, external == closing);
70 external->DestroyClosed();
71 }
72 return handler.GetIoStat() == IostatOk;
73 } else {
74 // There's a user-defined I/O subroutine, but there's a FORMAT present and
75 // it does not have a DT data edit descriptor, so apply default formatting
76 // to the components of the derived type as usual.
77 return std::nullopt;
78 }
79 }
80
81 // User-defined derived type unformatted I/O
DefinedUnformattedIo(IoStatementState & io,const Descriptor & descriptor,const typeInfo::SpecialBinding & special)82 bool DefinedUnformattedIo(IoStatementState &io, const Descriptor &descriptor,
83 const typeInfo::SpecialBinding &special) {
84 // Unformatted I/O must have an external unit (or child thereof).
85 IoErrorHandler &handler{io.GetIoErrorHandler()};
86 ExternalFileUnit *external{io.GetExternalFileUnit()};
87 RUNTIME_CHECK(handler, external != nullptr);
88 ChildIo &child{external->PushChildIo(io)};
89 int unit{external->unitNumber()};
90 int ioStat{IostatOk};
91 char ioMsg[100];
92 if (special.IsArgDescriptor(0)) {
93 auto *p{special.GetProc<void (*)(
94 const Descriptor &, int &, int &, char *, std::size_t)>()};
95 p(descriptor, unit, ioStat, ioMsg, sizeof ioMsg);
96 } else {
97 auto *p{special.GetProc<void (*)(
98 const void *, int &, int &, char *, std::size_t)>()};
99 p(descriptor.raw().base_addr, unit, ioStat, ioMsg, sizeof ioMsg);
100 }
101 handler.Forward(ioStat, ioMsg, sizeof ioMsg);
102 external->PopChildIo(child);
103 return handler.GetIoStat() == IostatOk;
104 }
105
106 } // namespace Fortran::runtime::io::descr
107