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