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

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