1 //===-- runtime/descriptor-io.h ---------------------------------*- 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 #ifndef FORTRAN_RUNTIME_DESCRIPTOR_IO_H_
10 #define FORTRAN_RUNTIME_DESCRIPTOR_IO_H_
11 
12 // Implementation of I/O data list item transfers based on descriptors.
13 // (All I/O items come through here so that the code is exercised for test;
14 // some scalar I/O data transfer APIs could be changed to bypass their use
15 // of descriptors in the future for better efficiency.)
16 
17 #include "edit-input.h"
18 #include "edit-output.h"
19 #include "io-stmt.h"
20 #include "terminator.h"
21 #include "type-info.h"
22 #include "unit.h"
23 #include "flang/Common/uint128.h"
24 #include "flang/Runtime/cpp-type.h"
25 #include "flang/Runtime/descriptor.h"
26 
27 namespace Fortran::runtime::io::descr {
28 template <typename A>
ExtractElement(IoStatementState & io,const Descriptor & descriptor,const SubscriptValue subscripts[])29 inline A &ExtractElement(IoStatementState &io, const Descriptor &descriptor,
30     const SubscriptValue subscripts[]) {
31   A *p{descriptor.Element<A>(subscripts)};
32   if (!p) {
33     io.GetIoErrorHandler().Crash(
34         "ExtractElement: null base address or subscripts out of range");
35   }
36   return *p;
37 }
38 
39 // Per-category descriptor-based I/O templates
40 
41 // TODO (perhaps as a nontrivial but small starter project): implement
42 // automatic repetition counts, like "10*3.14159", for list-directed and
43 // NAMELIST array output.
44 
45 template <int KIND, Direction DIR>
FormattedIntegerIO(IoStatementState & io,const Descriptor & descriptor)46 inline bool FormattedIntegerIO(
47     IoStatementState &io, const Descriptor &descriptor) {
48   std::size_t numElements{descriptor.Elements()};
49   SubscriptValue subscripts[maxRank];
50   descriptor.GetLowerBounds(subscripts);
51   using IntType = CppTypeFor<TypeCategory::Integer, KIND>;
52   bool anyInput{false};
53   for (std::size_t j{0}; j < numElements; ++j) {
54     if (auto edit{io.GetNextDataEdit()}) {
55       IntType &x{ExtractElement<IntType>(io, descriptor, subscripts)};
56       if constexpr (DIR == Direction::Output) {
57         if (!EditIntegerOutput<KIND>(io, *edit, x)) {
58           return false;
59         }
60       } else if (edit->descriptor != DataEdit::ListDirectedNullValue) {
61         if (EditIntegerInput(io, *edit, reinterpret_cast<void *>(&x), KIND)) {
62           anyInput = true;
63         } else {
64           return anyInput && edit->IsNamelist();
65         }
66       }
67       if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
68         io.GetIoErrorHandler().Crash(
69             "FormattedIntegerIO: subscripts out of bounds");
70       }
71     } else {
72       return false;
73     }
74   }
75   return true;
76 }
77 
78 template <int KIND, Direction DIR>
FormattedRealIO(IoStatementState & io,const Descriptor & descriptor)79 inline bool FormattedRealIO(
80     IoStatementState &io, const Descriptor &descriptor) {
81   std::size_t numElements{descriptor.Elements()};
82   SubscriptValue subscripts[maxRank];
83   descriptor.GetLowerBounds(subscripts);
84   using RawType = typename RealOutputEditing<KIND>::BinaryFloatingPoint;
85   bool anyInput{false};
86   for (std::size_t j{0}; j < numElements; ++j) {
87     if (auto edit{io.GetNextDataEdit()}) {
88       RawType &x{ExtractElement<RawType>(io, descriptor, subscripts)};
89       if constexpr (DIR == Direction::Output) {
90         if (!RealOutputEditing<KIND>{io, x}.Edit(*edit)) {
91           return false;
92         }
93       } else if (edit->descriptor != DataEdit::ListDirectedNullValue) {
94         if (EditRealInput<KIND>(io, *edit, reinterpret_cast<void *>(&x))) {
95           anyInput = true;
96         } else {
97           return anyInput && edit->IsNamelist();
98         }
99       }
100       if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
101         io.GetIoErrorHandler().Crash(
102             "FormattedRealIO: subscripts out of bounds");
103       }
104     } else {
105       return false;
106     }
107   }
108   return true;
109 }
110 
111 template <int KIND, Direction DIR>
FormattedComplexIO(IoStatementState & io,const Descriptor & descriptor)112 inline bool FormattedComplexIO(
113     IoStatementState &io, const Descriptor &descriptor) {
114   std::size_t numElements{descriptor.Elements()};
115   SubscriptValue subscripts[maxRank];
116   descriptor.GetLowerBounds(subscripts);
117   bool isListOutput{
118       io.get_if<ListDirectedStatementState<Direction::Output>>() != nullptr};
119   using RawType = typename RealOutputEditing<KIND>::BinaryFloatingPoint;
120   bool anyInput{false};
121   for (std::size_t j{0}; j < numElements; ++j) {
122     RawType *x{&ExtractElement<RawType>(io, descriptor, subscripts)};
123     if (isListOutput) {
124       DataEdit rEdit, iEdit;
125       rEdit.descriptor = DataEdit::ListDirectedRealPart;
126       iEdit.descriptor = DataEdit::ListDirectedImaginaryPart;
127       rEdit.modes = iEdit.modes = io.mutableModes();
128       if (!RealOutputEditing<KIND>{io, x[0]}.Edit(rEdit) ||
129           !RealOutputEditing<KIND>{io, x[1]}.Edit(iEdit)) {
130         return false;
131       }
132     } else {
133       for (int k{0}; k < 2; ++k, ++x) {
134         auto edit{io.GetNextDataEdit()};
135         if (!edit) {
136           return false;
137         } else if constexpr (DIR == Direction::Output) {
138           if (!RealOutputEditing<KIND>{io, *x}.Edit(*edit)) {
139             return false;
140           }
141         } else if (edit->descriptor == DataEdit::ListDirectedNullValue) {
142           break;
143         } else if (EditRealInput<KIND>(
144                        io, *edit, reinterpret_cast<void *>(x))) {
145           anyInput = true;
146         } else {
147           return anyInput && edit->IsNamelist();
148         }
149       }
150     }
151     if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
152       io.GetIoErrorHandler().Crash(
153           "FormattedComplexIO: subscripts out of bounds");
154     }
155   }
156   return true;
157 }
158 
159 template <typename A, Direction DIR>
FormattedCharacterIO(IoStatementState & io,const Descriptor & descriptor)160 inline bool FormattedCharacterIO(
161     IoStatementState &io, const Descriptor &descriptor) {
162   std::size_t numElements{descriptor.Elements()};
163   SubscriptValue subscripts[maxRank];
164   descriptor.GetLowerBounds(subscripts);
165   std::size_t length{descriptor.ElementBytes() / sizeof(A)};
166   auto *listOutput{io.get_if<ListDirectedStatementState<Direction::Output>>()};
167   bool anyInput{false};
168   for (std::size_t j{0}; j < numElements; ++j) {
169     A *x{&ExtractElement<A>(io, descriptor, subscripts)};
170     if (listOutput) {
171       if (!ListDirectedCharacterOutput(io, *listOutput, x, length)) {
172         return false;
173       }
174     } else if (auto edit{io.GetNextDataEdit()}) {
175       if constexpr (DIR == Direction::Output) {
176         if (!EditCharacterOutput(io, *edit, x, length)) {
177           return false;
178         }
179       } else { // input
180         if (edit->descriptor != DataEdit::ListDirectedNullValue) {
181           if (EditCharacterInput(io, *edit, x, length)) {
182             anyInput = true;
183           } else {
184             return anyInput && edit->IsNamelist();
185           }
186         }
187       }
188     } else {
189       return false;
190     }
191     if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
192       io.GetIoErrorHandler().Crash(
193           "FormattedCharacterIO: subscripts out of bounds");
194     }
195   }
196   return true;
197 }
198 
199 template <int KIND, Direction DIR>
FormattedLogicalIO(IoStatementState & io,const Descriptor & descriptor)200 inline bool FormattedLogicalIO(
201     IoStatementState &io, const Descriptor &descriptor) {
202   std::size_t numElements{descriptor.Elements()};
203   SubscriptValue subscripts[maxRank];
204   descriptor.GetLowerBounds(subscripts);
205   auto *listOutput{io.get_if<ListDirectedStatementState<Direction::Output>>()};
206   using IntType = CppTypeFor<TypeCategory::Integer, KIND>;
207   bool anyInput{false};
208   for (std::size_t j{0}; j < numElements; ++j) {
209     IntType &x{ExtractElement<IntType>(io, descriptor, subscripts)};
210     if (listOutput) {
211       if (!ListDirectedLogicalOutput(io, *listOutput, x != 0)) {
212         return false;
213       }
214     } else if (auto edit{io.GetNextDataEdit()}) {
215       if constexpr (DIR == Direction::Output) {
216         if (!EditLogicalOutput(io, *edit, x != 0)) {
217           return false;
218         }
219       } else {
220         if (edit->descriptor != DataEdit::ListDirectedNullValue) {
221           bool truth{};
222           if (EditLogicalInput(io, *edit, truth)) {
223             x = truth;
224             anyInput = true;
225           } else {
226             return anyInput && edit->IsNamelist();
227           }
228         }
229       }
230     } else {
231       return false;
232     }
233     if (!descriptor.IncrementSubscripts(subscripts) && j + 1 < numElements) {
234       io.GetIoErrorHandler().Crash(
235           "FormattedLogicalIO: subscripts out of bounds");
236     }
237   }
238   return true;
239 }
240 
241 template <Direction DIR>
242 static bool DescriptorIO(IoStatementState &, const Descriptor &);
243 
244 template <Direction DIR>
DefaultFormattedComponentIO(IoStatementState & io,const typeInfo::Component & component,const Descriptor & origDescriptor,const SubscriptValue origSubscripts[],Terminator & terminator)245 static bool DefaultFormattedComponentIO(IoStatementState &io,
246     const typeInfo::Component &component, const Descriptor &origDescriptor,
247     const SubscriptValue origSubscripts[], Terminator &terminator) {
248   if (component.genre() == typeInfo::Component::Genre::Data) {
249     // Create a descriptor for the component
250     StaticDescriptor<maxRank, true, 16 /*?*/> statDesc;
251     Descriptor &desc{statDesc.descriptor()};
252     component.CreatePointerDescriptor(
253         desc, origDescriptor, terminator, origSubscripts);
254     return DescriptorIO<DIR>(io, desc);
255   } else {
256     // Component is itself a descriptor
257     char *pointer{
258         origDescriptor.Element<char>(origSubscripts) + component.offset()};
259     RUNTIME_CHECK(
260         terminator, component.genre() == typeInfo::Component::Genre::Automatic);
261     const Descriptor &compDesc{*reinterpret_cast<const Descriptor *>(pointer)};
262     return DescriptorIO<DIR>(io, compDesc);
263   }
264 }
265 
266 std::optional<bool> DefinedFormattedIo(
267     IoStatementState &, const Descriptor &, const typeInfo::SpecialBinding &);
268 
269 template <Direction DIR>
FormattedDerivedTypeIO(IoStatementState & io,const Descriptor & descriptor)270 static bool FormattedDerivedTypeIO(
271     IoStatementState &io, const Descriptor &descriptor) {
272   IoErrorHandler &handler{io.GetIoErrorHandler()};
273   // Derived type information must be present for formatted I/O.
274   const DescriptorAddendum *addendum{descriptor.Addendum()};
275   RUNTIME_CHECK(handler, addendum != nullptr);
276   const typeInfo::DerivedType *type{addendum->derivedType()};
277   RUNTIME_CHECK(handler, type != nullptr);
278   if (const typeInfo::SpecialBinding *
279       special{type->FindSpecialBinding(DIR == Direction::Input
280               ? typeInfo::SpecialBinding::Which::ReadFormatted
281               : typeInfo::SpecialBinding::Which::WriteFormatted)}) {
282     if (std::optional<bool> wasDefined{
283             DefinedFormattedIo(io, descriptor, *special)}) {
284       return *wasDefined; // user-defined I/O was applied
285     }
286   }
287   // Default componentwise derived type formatting
288   const Descriptor &compArray{type->component()};
289   RUNTIME_CHECK(handler, compArray.rank() == 1);
290   std::size_t numComponents{compArray.Elements()};
291   std::size_t numElements{descriptor.Elements()};
292   SubscriptValue subscripts[maxRank];
293   descriptor.GetLowerBounds(subscripts);
294   for (std::size_t j{0}; j < numElements;
295        ++j, descriptor.IncrementSubscripts(subscripts)) {
296     SubscriptValue at[maxRank];
297     compArray.GetLowerBounds(at);
298     for (std::size_t k{0}; k < numComponents;
299          ++k, compArray.IncrementSubscripts(at)) {
300       const typeInfo::Component &component{
301           *compArray.Element<typeInfo::Component>(at)};
302       if (!DefaultFormattedComponentIO<DIR>(
303               io, component, descriptor, subscripts, handler)) {
304         return false;
305       }
306     }
307   }
308   return true;
309 }
310 
311 bool DefinedUnformattedIo(
312     IoStatementState &, const Descriptor &, const typeInfo::SpecialBinding &);
313 
314 // Unformatted I/O
315 template <Direction DIR>
UnformattedDescriptorIO(IoStatementState & io,const Descriptor & descriptor)316 static bool UnformattedDescriptorIO(
317     IoStatementState &io, const Descriptor &descriptor) {
318   IoErrorHandler &handler{io.GetIoErrorHandler()};
319   const DescriptorAddendum *addendum{descriptor.Addendum()};
320   const typeInfo::DerivedType *type{
321       addendum ? addendum->derivedType() : nullptr};
322   if (const typeInfo::SpecialBinding *
323       special{type
324               ? type->FindSpecialBinding(DIR == Direction::Input
325                         ? typeInfo::SpecialBinding::Which::ReadUnformatted
326                         : typeInfo::SpecialBinding::Which::WriteUnformatted)
327               : nullptr}) {
328     // User-defined derived type unformatted I/O
329     return DefinedUnformattedIo(io, descriptor, *special);
330   } else {
331     // Regular derived type unformatted I/O, not user-defined
332     auto *externalUnf{io.get_if<ExternalUnformattedIoStatementState<DIR>>()};
333     auto *childUnf{io.get_if<ChildUnformattedIoStatementState<DIR>>()};
334     auto *inq{
335         DIR == Direction::Output ? io.get_if<InquireIOLengthState>() : nullptr};
336     RUNTIME_CHECK(handler, externalUnf || childUnf || inq);
337     std::size_t elementBytes{descriptor.ElementBytes()};
338     std::size_t numElements{descriptor.Elements()};
339     SubscriptValue subscripts[maxRank];
340     descriptor.GetLowerBounds(subscripts);
341     using CharType =
342         std::conditional_t<DIR == Direction::Output, const char, char>;
343     auto Transfer{[=](CharType &x, std::size_t totalBytes,
344                       std::size_t elementBytes) -> bool {
345       if constexpr (DIR == Direction::Output) {
346         return externalUnf ? externalUnf->Emit(&x, totalBytes, elementBytes)
347             : childUnf     ? childUnf->Emit(&x, totalBytes, elementBytes)
348                            : inq->Emit(&x, totalBytes, elementBytes);
349       } else {
350         return externalUnf ? externalUnf->Receive(&x, totalBytes, elementBytes)
351                            : childUnf->Receive(&x, totalBytes, elementBytes);
352       }
353     }};
354     if (descriptor.IsContiguous()) { // contiguous unformatted I/O
355       char &x{ExtractElement<char>(io, descriptor, subscripts)};
356       return Transfer(x, numElements * elementBytes, elementBytes);
357     } else { // non-contiguous unformatted I/O
358       for (std::size_t j{0}; j < numElements; ++j) {
359         char &x{ExtractElement<char>(io, descriptor, subscripts)};
360         if (!Transfer(x, elementBytes, elementBytes)) {
361           return false;
362         }
363         if (!descriptor.IncrementSubscripts(subscripts) &&
364             j + 1 < numElements) {
365           handler.Crash("DescriptorIO: subscripts out of bounds");
366         }
367       }
368       return true;
369     }
370   }
371 }
372 
373 template <Direction DIR>
DescriptorIO(IoStatementState & io,const Descriptor & descriptor)374 static bool DescriptorIO(IoStatementState &io, const Descriptor &descriptor) {
375   IoErrorHandler &handler{io.GetIoErrorHandler()};
376   if (handler.InError()) {
377     return false;
378   }
379   if (!io.get_if<IoDirectionState<DIR>>()) {
380     io.GetIoErrorHandler().Crash(
381         "DescriptorIO() called for wrong I/O direction");
382     return false;
383   }
384   if constexpr (DIR == Direction::Input) {
385     if (!io.BeginReadingRecord()) {
386       return false;
387     }
388   }
389   if (!io.get_if<FormattedIoStatementState<DIR>>()) {
390     return UnformattedDescriptorIO<DIR>(io, descriptor);
391   }
392   if (auto catAndKind{descriptor.type().GetCategoryAndKind()}) {
393     TypeCategory cat{catAndKind->first};
394     int kind{catAndKind->second};
395     switch (cat) {
396     case TypeCategory::Integer:
397       switch (kind) {
398       case 1:
399         return FormattedIntegerIO<1, DIR>(io, descriptor);
400       case 2:
401         return FormattedIntegerIO<2, DIR>(io, descriptor);
402       case 4:
403         return FormattedIntegerIO<4, DIR>(io, descriptor);
404       case 8:
405         return FormattedIntegerIO<8, DIR>(io, descriptor);
406       case 16:
407         return FormattedIntegerIO<16, DIR>(io, descriptor);
408       default:
409         handler.Crash(
410             "DescriptorIO: Unimplemented INTEGER kind (%d) in descriptor",
411             kind);
412         return false;
413       }
414     case TypeCategory::Real:
415       switch (kind) {
416       case 2:
417         return FormattedRealIO<2, DIR>(io, descriptor);
418       case 3:
419         return FormattedRealIO<3, DIR>(io, descriptor);
420       case 4:
421         return FormattedRealIO<4, DIR>(io, descriptor);
422       case 8:
423         return FormattedRealIO<8, DIR>(io, descriptor);
424       case 10:
425         return FormattedRealIO<10, DIR>(io, descriptor);
426       // TODO: case double/double
427       case 16:
428         return FormattedRealIO<16, DIR>(io, descriptor);
429       default:
430         handler.Crash(
431             "DescriptorIO: Unimplemented REAL kind (%d) in descriptor", kind);
432         return false;
433       }
434     case TypeCategory::Complex:
435       switch (kind) {
436       case 2:
437         return FormattedComplexIO<2, DIR>(io, descriptor);
438       case 3:
439         return FormattedComplexIO<3, DIR>(io, descriptor);
440       case 4:
441         return FormattedComplexIO<4, DIR>(io, descriptor);
442       case 8:
443         return FormattedComplexIO<8, DIR>(io, descriptor);
444       case 10:
445         return FormattedComplexIO<10, DIR>(io, descriptor);
446       // TODO: case double/double
447       case 16:
448         return FormattedComplexIO<16, DIR>(io, descriptor);
449       default:
450         handler.Crash(
451             "DescriptorIO: Unimplemented COMPLEX kind (%d) in descriptor",
452             kind);
453         return false;
454       }
455     case TypeCategory::Character:
456       switch (kind) {
457       case 1:
458         return FormattedCharacterIO<char, DIR>(io, descriptor);
459       case 2:
460         return FormattedCharacterIO<char16_t, DIR>(io, descriptor);
461       case 4:
462         return FormattedCharacterIO<char32_t, DIR>(io, descriptor);
463       default:
464         handler.Crash(
465             "DescriptorIO: Unimplemented CHARACTER kind (%d) in descriptor",
466             kind);
467         return false;
468       }
469     case TypeCategory::Logical:
470       switch (kind) {
471       case 1:
472         return FormattedLogicalIO<1, DIR>(io, descriptor);
473       case 2:
474         return FormattedLogicalIO<2, DIR>(io, descriptor);
475       case 4:
476         return FormattedLogicalIO<4, DIR>(io, descriptor);
477       case 8:
478         return FormattedLogicalIO<8, DIR>(io, descriptor);
479       default:
480         handler.Crash(
481             "DescriptorIO: Unimplemented LOGICAL kind (%d) in descriptor",
482             kind);
483         return false;
484       }
485     case TypeCategory::Derived:
486       return FormattedDerivedTypeIO<DIR>(io, descriptor);
487     }
488   }
489   handler.Crash("DescriptorIO: bad type code (%d) in descriptor",
490       static_cast<int>(descriptor.type().raw()));
491   return false;
492 }
493 } // namespace Fortran::runtime::io::descr
494 #endif // FORTRAN_RUNTIME_DESCRIPTOR_IO_H_
495