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