1//===-- lib/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 "flang-rt/runtime/namelist.h"
10#include "descriptor-io.h"
11#include "flang-rt/runtime/emit-encoded.h"
12#include "flang-rt/runtime/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
20RT_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.
23static constexpr RT_CONST_VAR_ATTRS std::size_t nameBufferSize{201};
24RT_VAR_GROUP_END
25
26RT_OFFLOAD_API_GROUP_BEGIN
27
28static inline RT_API_ATTRS char32_t GetComma(IoStatementState &io) {
29 return io.mutableModes().editingFlags & decimalComma ? char32_t{';'}
30 : char32_t{','};
31}
32
33bool 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
92static constexpr RT_API_ATTRS bool IsLegalIdStart(char32_t ch) {
93 return (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || ch == '_' ||
94 ch == '@';
95}
96
97static constexpr RT_API_ATTRS bool IsLegalIdChar(char32_t ch) {
98 return IsLegalIdStart(ch) || (ch >= '0' && ch <= '9');
99}
100
101static constexpr RT_API_ATTRS char NormalizeIdChar(char32_t ch) {
102 return static_cast<char>(ch >= 'A' && ch <= 'Z' ? ch - 'A' + 'a' : ch);
103}
104
105static 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
127static 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
160static 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
260static 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
282static 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
343static 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, compName, 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.
417static 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
440bool 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, mutableDescriptor, *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(*lastSubscriptDescriptor, *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
599RT_API_ATTRS 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
623RT_OFFLOAD_API_GROUP_END
624
625} // namespace Fortran::runtime::io
626

source code of flang-rt/lib/runtime/namelist.cpp