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)
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(1)}; // now consume it; no repeats
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
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