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