1 //===-- runtime/namelist.cpp ------------------------------------*- 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 #include "namelist.h"
10 #include "descriptor-io.h"
11 #include "io-api.h"
12 #include "io-stmt.h"
13 #include <cstring>
14 #include <limits>
15 
16 namespace Fortran::runtime::io {
17 
18 bool IONAME(OutputNamelist)(Cookie cookie, const NamelistGroup &group) {
19   IoStatementState &io{*cookie};
20   io.CheckFormattedStmtType<Direction::Output>("OutputNamelist");
21   ConnectionState &connection{io.GetConnectionState()};
22   connection.modes.inNamelist = true;
23   // Internal functions to advance records and convert case
24   const auto EmitWithAdvance{[&](char ch) -> bool {
25     return (!connection.NeedAdvance(1) || io.AdvanceRecord()) &&
26         io.Emit(&ch, 1);
27   }};
28   const auto EmitUpperCase{[&](const char *str) -> bool {
29     if (connection.NeedAdvance(std::strlen(str)) &&
30         !(io.AdvanceRecord() && io.Emit(" ", 1))) {
31       return false;
32     }
33     for (; *str; ++str) {
34       char up{*str >= 'a' && *str <= 'z' ? static_cast<char>(*str - 'a' + 'A')
35                                          : *str};
36       if (!io.Emit(&up, 1)) {
37         return false;
38       }
39     }
40     return true;
41   }};
42   // &GROUP
43   if (!(EmitWithAdvance('&') && EmitUpperCase(group.groupName))) {
44     return false;
45   }
46   for (std::size_t j{0}; j < group.items; ++j) {
47     // [,]ITEM=...
48     const NamelistGroup::Item &item{group.item[j]};
49     if (!(EmitWithAdvance(j == 0 ? ' ' : ',') && EmitUpperCase(item.name) &&
50             EmitWithAdvance('=') &&
51             descr::DescriptorIO<Direction::Output>(io, item.descriptor))) {
52       return false;
53     }
54   }
55   // terminal /
56   return EmitWithAdvance('/');
57 }
58 
59 static bool GetLowerCaseName(
60     IoStatementState &io, char buffer[], std::size_t maxLength) {
61   if (auto ch{io.GetCurrentChar()}) {
62     static const auto IsLegalIdStart{[](char32_t ch) -> bool {
63       return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') ||
64           ch == '_' || ch == '@' || ch == '$';
65     }};
66     if (IsLegalIdStart(*ch)) {
67       std::size_t j{0};
68       do {
69         buffer[j] =
70             static_cast<char>(*ch >= 'A' && *ch <= 'Z' ? *ch - 'A' + 'a' : *ch);
71         io.HandleRelativePosition(1);
72         ch = io.GetCurrentChar();
73       } while (++j < maxLength && ch &&
74           (IsLegalIdStart(*ch) || (*ch >= '0' && *ch <= '9')));
75       buffer[j++] = '\0';
76       if (j <= maxLength) {
77         return true;
78       }
79       io.GetIoErrorHandler().SignalError(
80           "Identifier '%s...' in NAMELIST input group is too long", buffer);
81     }
82   }
83   return false;
84 }
85 
86 static std::optional<SubscriptValue> GetSubscriptValue(IoStatementState &io) {
87   std::optional<SubscriptValue> value;
88   std::optional<char32_t> ch{io.GetCurrentChar()};
89   bool negate{ch && *ch == '-'};
90   if (negate) {
91     io.HandleRelativePosition(1);
92     ch = io.GetCurrentChar();
93   }
94   bool overflow{false};
95   while (ch && *ch >= '0' && *ch <= '9') {
96     SubscriptValue was{value.value_or(0)};
97     overflow |= was >= std::numeric_limits<SubscriptValue>::max() / 10;
98     value = 10 * was + *ch - '0';
99     io.HandleRelativePosition(1);
100     ch = io.GetCurrentChar();
101   }
102   if (overflow) {
103     io.GetIoErrorHandler().SignalError(
104         "NAMELIST input subscript value overflow");
105     return std::nullopt;
106   }
107   if (negate) {
108     if (value) {
109       return -*value;
110     } else {
111       io.HandleRelativePosition(-1); // give back '-' with no digits
112     }
113   }
114   return value;
115 }
116 
117 static bool HandleSubscripts(IoStatementState &io, Descriptor &desc,
118     const Descriptor &source, const char *name) {
119   IoErrorHandler &handler{io.GetIoErrorHandler()};
120   io.HandleRelativePosition(1); // skip '('
121   // Allow for blanks in subscripts; it's nonstandard, but not ambiguous
122   // within the parentheses
123   SubscriptValue lower[maxRank], upper[maxRank], stride[maxRank];
124   int j{0};
125   std::size_t elemLen{source.ElementBytes()};
126   bool ok{true};
127   std::optional<char32_t> ch{io.GetNextNonBlank()};
128   for (; ch && *ch != ')'; ++j) {
129     SubscriptValue dimLower{0}, dimUpper{0}, dimStride{0};
130     if (j < maxRank && j < source.rank()) {
131       const Dimension &dim{source.GetDimension(j)};
132       dimLower = dim.LowerBound();
133       dimUpper = dim.UpperBound();
134       dimStride = elemLen ? dim.ByteStride() / elemLen : 1;
135     } else if (ok) {
136       handler.SignalError(
137           "Too many subscripts for rank-%d NAMELIST group item '%s'",
138           source.rank(), name);
139       ok = false;
140     }
141     if (auto low{GetSubscriptValue(io)}) {
142       if (*low < dimLower || (dimUpper >= dimLower && *low > dimUpper)) {
143         if (ok) {
144           handler.SignalError("Subscript %jd out of range %jd..%jd in NAMELIST "
145                               "group item '%s' dimension %d",
146               static_cast<std::intmax_t>(*low),
147               static_cast<std::intmax_t>(dimLower),
148               static_cast<std::intmax_t>(dimUpper), name, j + 1);
149           ok = false;
150         }
151       } else {
152         dimLower = *low;
153       }
154       ch = io.GetNextNonBlank();
155     }
156     if (ch && *ch == ':') {
157       io.HandleRelativePosition(1);
158       ch = io.GetNextNonBlank();
159       if (auto high{GetSubscriptValue(io)}) {
160         if (*high > dimUpper) {
161           if (ok) {
162             handler.SignalError(
163                 "Subscript triplet upper bound %jd out of range (>%jd) in "
164                 "NAMELIST group item '%s' dimension %d",
165                 static_cast<std::intmax_t>(*high),
166                 static_cast<std::intmax_t>(dimUpper), name, j + 1);
167             ok = false;
168           }
169         } else {
170           dimUpper = *high;
171         }
172         ch = io.GetNextNonBlank();
173       }
174       if (ch && *ch == ':') {
175         io.HandleRelativePosition(1);
176         ch = io.GetNextNonBlank();
177         if (auto str{GetSubscriptValue(io)}) {
178           dimStride = *str;
179           ch = io.GetNextNonBlank();
180         }
181       }
182     } else { // scalar
183       dimUpper = dimLower;
184       dimStride = 0;
185     }
186     if (ch && *ch == ',') {
187       io.HandleRelativePosition(1);
188       ch = io.GetNextNonBlank();
189     }
190     if (ok) {
191       lower[j] = dimLower;
192       upper[j] = dimUpper;
193       stride[j] = dimStride;
194     }
195   }
196   if (ok) {
197     if (ch && *ch == ')') {
198       io.HandleRelativePosition(1);
199       if (desc.EstablishPointerSection(source, lower, upper, stride)) {
200         return true;
201       } else {
202         handler.SignalError(
203             "Bad subscripts for NAMELIST input group item '%s'", name);
204       }
205     } else {
206       handler.SignalError(
207           "Bad subscripts (missing ')') for NAMELIST input group item '%s'",
208           name);
209     }
210   }
211   return false;
212 }
213 
214 bool IONAME(InputNamelist)(Cookie cookie, const NamelistGroup &group) {
215   IoStatementState &io{*cookie};
216   io.CheckFormattedStmtType<Direction::Input>("InputNamelist");
217   ConnectionState &connection{io.GetConnectionState()};
218   connection.modes.inNamelist = true;
219   IoErrorHandler &handler{io.GetIoErrorHandler()};
220   // Check the group header
221   std::optional<char32_t> next{io.GetNextNonBlank()};
222   if (!next || *next != '&') {
223     handler.SignalError(
224         "NAMELIST input group does not begin with '&' (at '%lc')", *next);
225     return false;
226   }
227   io.HandleRelativePosition(1);
228   char name[101];
229   if (!GetLowerCaseName(io, name, sizeof name)) {
230     handler.SignalError("NAMELIST input group has no name");
231     return false;
232   }
233   RUNTIME_CHECK(handler, group.groupName != nullptr);
234   if (std::strcmp(group.groupName, name) != 0) {
235     handler.SignalError(
236         "NAMELIST input group name '%s' is not the expected '%s'", name,
237         group.groupName);
238     return false;
239   }
240   // Read the group's items
241   while (true) {
242     next = io.GetNextNonBlank();
243     if (!next || *next == '/') {
244       break;
245     }
246     if (!GetLowerCaseName(io, name, sizeof name)) {
247       handler.SignalError(
248           "NAMELIST input group '%s' was not terminated", group.groupName);
249       return false;
250     }
251     std::size_t itemIndex{0};
252     for (; itemIndex < group.items; ++itemIndex) {
253       if (std::strcmp(name, group.item[itemIndex].name) == 0) {
254         break;
255       }
256     }
257     if (itemIndex >= group.items) {
258       handler.SignalError(
259           "'%s' is not an item in NAMELIST group '%s'", name, group.groupName);
260       return false;
261     }
262     // Handle indexing and components, if any.  No spaces are allowed.
263     // A copy of the descriptor is made if necessary.
264     const Descriptor &itemDescriptor{group.item[itemIndex].descriptor};
265     const Descriptor *useDescriptor{&itemDescriptor};
266     StaticDescriptor<maxRank, true, 16> staticDesc[2];
267     int whichStaticDesc{0};
268     next = io.GetCurrentChar();
269     if (next && (*next == '(' || *next == '%')) {
270       do {
271         if (*next == '(') {
272           Descriptor &mutableDescriptor{
273               staticDesc[whichStaticDesc].descriptor()};
274           whichStaticDesc ^= 1;
275           HandleSubscripts(io, mutableDescriptor, *useDescriptor, name);
276           useDescriptor = &mutableDescriptor;
277         } else {
278           handler.Crash("unimplemented: component references in NAMELIST");
279         }
280         next = io.GetCurrentChar();
281       } while (next && (*next == '(' || *next == '%'));
282     }
283     // Skip the '='
284     next = io.GetNextNonBlank();
285     if (!next || *next != '=') {
286       handler.SignalError("No '=' found after item '%s' in NAMELIST group '%s'",
287           name, group.groupName);
288       return false;
289     }
290     io.HandleRelativePosition(1);
291     // Read the values into the descriptor
292     if (!descr::DescriptorIO<Direction::Input>(io, *useDescriptor)) {
293       return false;
294     }
295     next = io.GetNextNonBlank();
296     if (next && *next == ',') {
297       io.HandleRelativePosition(1);
298     }
299   }
300   if (!next || *next != '/') {
301     handler.SignalError(
302         "No '/' found after NAMELIST group '%s'", group.groupName);
303     return false;
304   }
305   io.HandleRelativePosition(1);
306   return true;
307 }
308 
309 } // namespace Fortran::runtime::io
310