1 //===-- runtime/namelist.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 "namelist.h"
10 #include "descriptor-io.h"
11 #include "io-stmt.h"
12 #include "flang/Runtime/io-api.h"
13 #include <algorithm>
14 #include <cstring>
15 #include <limits>
16 
17 namespace Fortran::runtime::io {
18 
19 // Max size of a group, symbol or component identifier that can appear in
20 // NAMELIST input, plus a byte for NUL termination.
21 static constexpr std::size_t nameBufferSize{201};
22 
23 static inline char32_t GetComma(IoStatementState &io) {
24   return io.mutableModes().editingFlags & decimalComma ? char32_t{';'}
25                                                        : char32_t{','};
26 }
27 
28 bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
29   IoStatementState &io{*cookie};
30   io.CheckFormattedStmtType<Direction::Output>("OutputNamelist");
31   ConnectionState &connection{io.GetConnectionState()};
32   connection.modes.inNamelist = true;
33   char comma{static_cast<char>(GetComma(io))};
34   // Internal functions to advance records and convert case
35   const auto EmitWithAdvance{[&](char ch) -> bool {
36     return (!connection.NeedAdvance(1) || io.AdvanceRecord()) &&
37         io.Emit(&ch, 1);
38   }};
39   const auto EmitUpperCase{[&](const char *str) -> bool {
40     if (connection.NeedAdvance(std::strlen(str)) &&
41         !(io.AdvanceRecord() && io.Emit(" ", 1))) {
42       return false;
43     }
44     for (; *str; ++str) {
45       char up{*str >= 'a' && *str <= 'z' ? static_cast<char>(*str - 'a' + 'A')
46                                          : *str};
47       if (!io.Emit(&up, 1)) {
48         return false;
49       }
50     }
51     return true;
52   }};
53   // &GROUP
54   if (!(EmitWithAdvance('&') && EmitUpperCase(group.groupName))) {
55     return false;
56   }
57   for (std::size_t j{0}; j < group.items; ++j) {
58     // [,]ITEM=...
59     const NamelistGroup::Item &item{group.item[j]};
60     if (!(EmitWithAdvance(j == 0 ? ' ' : comma) && EmitUpperCase(item.name) &&
61             EmitWithAdvance('=') &&
62             descr::DescriptorIO<Direction::Output>(io, item.descriptor))) {
63       return false;
64     }
65   }
66   // terminal /
67   return EmitWithAdvance('/');
68 }
69 
70 static constexpr bool IsLegalIdStart(char32_t ch) {
71   return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || ch == '_' ||
72       ch == '@' || ch == '$';
73 }
74 
75 static constexpr bool IsLegalIdChar(char32_t ch) {
76   return IsLegalIdStart(ch) || (ch >= '0' && ch <= '9');
77 }
78 
79 static constexpr char NormalizeIdChar(char32_t ch) {
80   return static_cast<char>(ch >= 'A' && ch <= 'Z' ? ch - 'A' + 'a' : ch);
81 }
82 
83 static bool GetLowerCaseName(
84     IoStatementState &io, char buffer[], std::size_t maxLength) {
85   if (auto ch{io.GetNextNonBlank()}) {
86     if (IsLegalIdStart(*ch)) {
87       std::size_t j{0};
88       do {
89         buffer[j] = NormalizeIdChar(*ch);
90         io.HandleRelativePosition(1);
91         ch = io.GetCurrentChar();
92       } while (++j < maxLength && ch && IsLegalIdChar(*ch));
93       buffer[j++] = '\0';
94       if (j <= maxLength) {
95         return true;
96       }
97       io.GetIoErrorHandler().SignalError(
98           "Identifier '%s...' in NAMELIST input group is too long", buffer);
99     }
100   }
101   return false;
102 }
103 
104 static std::optional<SubscriptValue> GetSubscriptValue(IoStatementState &io) {
105   std::optional<SubscriptValue> value;
106   std::optional<char32_t> ch{io.GetCurrentChar()};
107   bool negate{ch && *ch == '-'};
108   if ((ch && *ch == '+') || negate) {
109     io.HandleRelativePosition(1);
110     ch = io.GetCurrentChar();
111   }
112   bool overflow{false};
113   while (ch && *ch >= '0' && *ch <= '9') {
114     SubscriptValue was{value.value_or(0)};
115     overflow |= was >= std::numeric_limits<SubscriptValue>::max() / 10;
116     value = 10 * was + *ch - '0';
117     io.HandleRelativePosition(1);
118     ch = io.GetCurrentChar();
119   }
120   if (overflow) {
121     io.GetIoErrorHandler().SignalError(
122         "NAMELIST input subscript value overflow");
123     return std::nullopt;
124   }
125   if (negate) {
126     if (value) {
127       return -*value;
128     } else {
129       io.HandleRelativePosition(-1); // give back '-' with no digits
130     }
131   }
132   return value;
133 }
134 
135 static bool HandleSubscripts(IoStatementState &io, Descriptor &desc,
136     const Descriptor &source, const char *name) {
137   IoErrorHandler &handler{io.GetIoErrorHandler()};
138   io.HandleRelativePosition(1); // skip '('
139   // Allow for blanks in subscripts; they're nonstandard, but not
140   // ambiguous within the parentheses.
141   SubscriptValue lower[maxRank], upper[maxRank], stride[maxRank];
142   int j{0};
143   std::size_t contiguousStride{source.ElementBytes()};
144   bool ok{true};
145   std::optional<char32_t> ch{io.GetNextNonBlank()};
146   char32_t comma{GetComma(io)};
147   for (; ch && *ch != ')'; ++j) {
148     SubscriptValue dimLower{0}, dimUpper{0}, dimStride{0};
149     if (j < maxRank && j < source.rank()) {
150       const Dimension &dim{source.GetDimension(j)};
151       dimLower = dim.LowerBound();
152       dimUpper = dim.UpperBound();
153       dimStride =
154           dim.ByteStride() / std::max<SubscriptValue>(contiguousStride, 1);
155       contiguousStride *= dim.Extent();
156     } else if (ok) {
157       handler.SignalError(
158           "Too many subscripts for rank-%d NAMELIST group item '%s'",
159           source.rank(), name);
160       ok = false;
161     }
162     if (auto low{GetSubscriptValue(io)}) {
163       if (*low < dimLower || (dimUpper >= dimLower && *low > dimUpper)) {
164         if (ok) {
165           handler.SignalError("Subscript %jd out of range %jd..%jd in NAMELIST "
166                               "group item '%s' dimension %d",
167               static_cast<std::intmax_t>(*low),
168               static_cast<std::intmax_t>(dimLower),
169               static_cast<std::intmax_t>(dimUpper), name, j + 1);
170           ok = false;
171         }
172       } else {
173         dimLower = *low;
174       }
175       ch = io.GetNextNonBlank();
176     }
177     if (ch && *ch == ':') {
178       io.HandleRelativePosition(1);
179       ch = io.GetNextNonBlank();
180       if (auto high{GetSubscriptValue(io)}) {
181         if (*high > dimUpper) {
182           if (ok) {
183             handler.SignalError(
184                 "Subscript triplet upper bound %jd out of range (>%jd) in "
185                 "NAMELIST group item '%s' dimension %d",
186                 static_cast<std::intmax_t>(*high),
187                 static_cast<std::intmax_t>(dimUpper), name, j + 1);
188             ok = false;
189           }
190         } else {
191           dimUpper = *high;
192         }
193         ch = io.GetNextNonBlank();
194       }
195       if (ch && *ch == ':') {
196         io.HandleRelativePosition(1);
197         ch = io.GetNextNonBlank();
198         if (auto str{GetSubscriptValue(io)}) {
199           dimStride = *str;
200           ch = io.GetNextNonBlank();
201         }
202       }
203     } else { // scalar
204       dimUpper = dimLower;
205       dimStride = 0;
206     }
207     if (ch && *ch == comma) {
208       io.HandleRelativePosition(1);
209       ch = io.GetNextNonBlank();
210     }
211     if (ok) {
212       lower[j] = dimLower;
213       upper[j] = dimUpper;
214       stride[j] = dimStride;
215     }
216   }
217   if (ok) {
218     if (ch && *ch == ')') {
219       io.HandleRelativePosition(1);
220       if (desc.EstablishPointerSection(source, lower, upper, stride)) {
221         return true;
222       } else {
223         handler.SignalError(
224             "Bad subscripts for NAMELIST input group item '%s'", name);
225       }
226     } else {
227       handler.SignalError(
228           "Bad subscripts (missing ')') for NAMELIST input group item '%s'",
229           name);
230     }
231   }
232   return false;
233 }
234 
235 static bool HandleSubstring(
236     IoStatementState &io, Descriptor &desc, const char *name) {
237   IoErrorHandler &handler{io.GetIoErrorHandler()};
238   auto pair{desc.type().GetCategoryAndKind()};
239   if (!pair || pair->first != TypeCategory::Character) {
240     handler.SignalError("Substring reference to non-character item '%s'", name);
241     return false;
242   }
243   int kind{pair->second};
244   SubscriptValue chars{static_cast<SubscriptValue>(desc.ElementBytes()) / kind};
245   // Allow for blanks in substring bounds; they're nonstandard, but not
246   // ambiguous within the parentheses.
247   io.HandleRelativePosition(1); // skip '('
248   std::optional<SubscriptValue> lower, upper;
249   std::optional<char32_t> ch{io.GetNextNonBlank()};
250   if (ch) {
251     if (*ch == ':') {
252       lower = 1;
253     } else {
254       lower = GetSubscriptValue(io);
255       ch = io.GetNextNonBlank();
256     }
257   }
258   if (ch && ch == ':') {
259     io.HandleRelativePosition(1);
260     ch = io.GetNextNonBlank();
261     if (ch) {
262       if (*ch == ')') {
263         upper = chars;
264       } else {
265         upper = GetSubscriptValue(io);
266         ch = io.GetNextNonBlank();
267       }
268     }
269   }
270   if (ch && *ch == ')') {
271     io.HandleRelativePosition(1);
272     if (lower && upper) {
273       if (*lower > *upper) {
274         // An empty substring, whatever the values are
275         desc.raw().elem_len = 0;
276         return true;
277       }
278       if (*lower >= 1 || *upper <= chars) {
279         // Offset the base address & adjust the element byte length
280         desc.raw().elem_len = (*upper - *lower + 1) * kind;
281         desc.set_base_addr(reinterpret_cast<void *>(
282             reinterpret_cast<char *>(desc.raw().base_addr) +
283             kind * (*lower - 1)));
284         return true;
285       }
286     }
287     handler.SignalError(
288         "Bad substring bounds for NAMELIST input group item '%s'", name);
289   } else {
290     handler.SignalError(
291         "Bad substring (missing ')') for NAMELIST input group item '%s'", name);
292   }
293   return false;
294 }
295 
296 static bool HandleComponent(IoStatementState &io, Descriptor &desc,
297     const Descriptor &source, const char *name) {
298   IoErrorHandler &handler{io.GetIoErrorHandler()};
299   io.HandleRelativePosition(1); // skip '%'
300   char compName[nameBufferSize];
301   if (GetLowerCaseName(io, compName, sizeof compName)) {
302     const DescriptorAddendum *addendum{source.Addendum()};
303     if (const typeInfo::DerivedType *
304         type{addendum ? addendum->derivedType() : nullptr}) {
305       if (const typeInfo::Component *
306           comp{type->FindDataComponent(compName, std::strlen(compName))}) {
307         comp->CreatePointerDescriptor(desc, source, handler);
308         return true;
309       } else {
310         handler.SignalError(
311             "NAMELIST component reference '%%%s' of input group item %s is not "
312             "a component of its derived type",
313             compName, name);
314       }
315     } else if (source.type().IsDerived()) {
316       handler.Crash("Derived type object '%s' in NAMELIST is missing its "
317                     "derived type information!",
318           name);
319     } else {
320       handler.SignalError("NAMELIST component reference '%%%s' of input group "
321                           "item %s for non-derived type",
322           compName, name);
323     }
324   } else {
325     handler.SignalError("NAMELIST component reference of input group item %s "
326                         "has no name after '%'",
327         name);
328   }
329   return false;
330 }
331 
332 // Advance to the terminal '/' of a namelist group.
333 static void SkipNamelistGroup(IoStatementState &io) {
334   while (auto ch{io.GetNextNonBlank()}) {
335     io.HandleRelativePosition(1);
336     if (*ch == '/') {
337       break;
338     } else if (*ch == '\'' || *ch == '"') {
339       // Skip quoted character literal
340       char32_t quote{*ch};
341       while (true) {
342         if ((ch = io.GetCurrentChar())) {
343           io.HandleRelativePosition(1);
344           if (*ch == quote) {
345             break;
346           }
347         } else if (!io.AdvanceRecord()) {
348           return;
349         }
350       }
351     }
352   }
353 }
354 
355 bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
356   IoStatementState &io{*cookie};
357   io.CheckFormattedStmtType<Direction::Input>("InputNamelist");
358   ConnectionState &connection{io.GetConnectionState()};
359   connection.modes.inNamelist = true;
360   IoErrorHandler &handler{io.GetIoErrorHandler()};
361   auto *listInput{io.get_if<ListDirectedStatementState<Direction::Input>>()};
362   RUNTIME_CHECK(handler, listInput != nullptr);
363   // Find this namelist group's header in the input
364   io.BeginReadingRecord();
365   std::optional<char32_t> next;
366   char name[nameBufferSize];
367   RUNTIME_CHECK(handler, group.groupName != nullptr);
368   char32_t comma{GetComma(io)};
369   while (true) {
370     next = io.GetNextNonBlank();
371     while (next && *next != '&') {
372       // Extension: comment lines without ! before namelist groups
373       if (!io.AdvanceRecord()) {
374         next.reset();
375       } else {
376         next = io.GetNextNonBlank();
377       }
378     }
379     if (!next || *next != '&') {
380       handler.SignalError(
381           "NAMELIST input group does not begin with '&' (at '%lc')", *next);
382       return false;
383     }
384     io.HandleRelativePosition(1);
385     if (!GetLowerCaseName(io, name, sizeof name)) {
386       handler.SignalError("NAMELIST input group has no name");
387       return false;
388     }
389     if (std::strcmp(group.groupName, name) == 0) {
390       break; // found it
391     }
392     SkipNamelistGroup(io);
393   }
394   // Read the group's items
395   while (true) {
396     next = io.GetNextNonBlank();
397     if (!next || *next == '/') {
398       break;
399     }
400     if (!GetLowerCaseName(io, name, sizeof name)) {
401       handler.SignalError(
402           "NAMELIST input group '%s' was not terminated at '%c'",
403           group.groupName, static_cast<char>(*next));
404       return false;
405     }
406     std::size_t itemIndex{0};
407     for (; itemIndex < group.items; ++itemIndex) {
408       if (std::strcmp(name, group.item[itemIndex].name) == 0) {
409         break;
410       }
411     }
412     if (itemIndex >= group.items) {
413       handler.SignalError(
414           "'%s' is not an item in NAMELIST group '%s'", name, group.groupName);
415       return false;
416     }
417     // Handle indexing and components, if any.  No spaces are allowed.
418     // A copy of the descriptor is made if necessary.
419     const Descriptor &itemDescriptor{group.item[itemIndex].descriptor};
420     const Descriptor *useDescriptor{&itemDescriptor};
421     StaticDescriptor<maxRank, true, 16> staticDesc[2];
422     int whichStaticDesc{0};
423     next = io.GetCurrentChar();
424     bool hadSubscripts{false};
425     bool hadSubstring{false};
426     if (next && (*next == '(' || *next == '%')) {
427       do {
428         Descriptor &mutableDescriptor{staticDesc[whichStaticDesc].descriptor()};
429         whichStaticDesc ^= 1;
430         if (*next == '(') {
431           if (!hadSubstring && (hadSubscripts || useDescriptor->rank() == 0)) {
432             mutableDescriptor = *useDescriptor;
433             mutableDescriptor.raw().attribute = CFI_attribute_pointer;
434             if (!HandleSubstring(io, mutableDescriptor, name)) {
435               return false;
436             }
437             hadSubstring = true;
438           } else if (hadSubscripts) {
439             handler.SignalError("Multiple sets of subscripts for item '%s' in "
440                                 "NAMELIST group '%s'",
441                 name, group.groupName);
442             return false;
443           } else if (!HandleSubscripts(
444                          io, mutableDescriptor, *useDescriptor, name)) {
445             return false;
446           }
447           hadSubscripts = true;
448         } else {
449           if (!HandleComponent(io, mutableDescriptor, *useDescriptor, name)) {
450             return false;
451           }
452           hadSubscripts = false;
453           hadSubstring = false;
454         }
455         useDescriptor = &mutableDescriptor;
456         next = io.GetCurrentChar();
457       } while (next && (*next == '(' || *next == '%'));
458     }
459     // Skip the '='
460     next = io.GetNextNonBlank();
461     if (!next || *next != '=') {
462       handler.SignalError("No '=' found after item '%s' in NAMELIST group '%s'",
463           name, group.groupName);
464       return false;
465     }
466     io.HandleRelativePosition(1);
467     // Read the values into the descriptor.  An array can be short.
468     listInput->ResetForNextNamelistItem();
469     if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) {
470       return false;
471     }
472     next = io.GetNextNonBlank();
473     if (next && *next == comma) {
474       io.HandleRelativePosition(1);
475     }
476   }
477   if (!next || *next != '/') {
478     handler.SignalError(
479         "No '/' found after NAMELIST group '%s'", group.groupName);
480     return false;
481   }
482   io.HandleRelativePosition(1);
483   return true;
484 }
485 
486 bool IsNamelistName(IoStatementState &io) {
487   if (io.get_if<ListDirectedStatementState<Direction::Input>>()) {
488     ConnectionState &connection{io.GetConnectionState()};
489     if (connection.modes.inNamelist) {
490       SavedPosition savedPosition{io};
491       if (auto ch{io.GetNextNonBlank()}) {
492         if (IsLegalIdStart(*ch)) {
493           do {
494             io.HandleRelativePosition(1);
495             ch = io.GetCurrentChar();
496           } while (ch && IsLegalIdChar(*ch));
497           ch = io.GetNextNonBlank();
498           // TODO: how to deal with NaN(...) ambiguity?
499           return ch && (*ch == '=' || *ch == '(' || *ch == '%');
500         }
501       }
502     }
503   }
504   return false;
505 }
506 
507 } // namespace Fortran::runtime::io
508