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

source code of flang/runtime/namelist.cpp