1//===-- lib/Semantics/check-io.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 "check-io.h"
10#include "definable.h"
11#include "flang/Common/format.h"
12#include "flang/Common/indirection.h"
13#include "flang/Evaluate/tools.h"
14#include "flang/Parser/characters.h"
15#include "flang/Parser/tools.h"
16#include "flang/Semantics/expression.h"
17#include "flang/Semantics/tools.h"
18#include <unordered_map>
19
20namespace Fortran::semantics {
21
22// TODO: C1234, C1235 -- defined I/O constraints
23
24class FormatErrorReporter {
25public:
26 FormatErrorReporter(SemanticsContext &context,
27 const parser::CharBlock &formatCharBlock, int errorAllowance = 3)
28 : context_{context}, formatCharBlock_{formatCharBlock},
29 errorAllowance_{errorAllowance} {}
30
31 bool Say(const common::FormatMessage &);
32
33private:
34 SemanticsContext &context_;
35 const parser::CharBlock &formatCharBlock_;
36 int errorAllowance_; // initialized to maximum number of errors to report
37};
38
39bool FormatErrorReporter::Say(const common::FormatMessage &msg) {
40 if (!msg.isError &&
41 !context_.ShouldWarn(common::LanguageFeature::AdditionalFormats)) {
42 return false;
43 }
44 parser::MessageFormattedText text{
45 parser::MessageFixedText{msg.text, strlen(msg.text),
46 msg.isError ? parser::Severity::Error : parser::Severity::Warning},
47 msg.arg};
48 if (formatCharBlock_.size()) {
49 // The input format is a folded expression. Error markers span the full
50 // original unfolded expression in formatCharBlock_.
51 context_.Say(formatCharBlock_, text);
52 } else {
53 // The input format is a source expression. Error markers have an offset
54 // and length relative to the beginning of formatCharBlock_.
55 parser::CharBlock messageCharBlock{
56 parser::CharBlock(formatCharBlock_.begin() + msg.offset, msg.length)};
57 context_.Say(messageCharBlock, text);
58 }
59 return msg.isError && --errorAllowance_ <= 0;
60}
61
62void IoChecker::Enter(
63 const parser::Statement<common::Indirection<parser::FormatStmt>> &stmt) {
64 if (!stmt.label) {
65 context_.Say("Format statement must be labeled"_err_en_US); // C1301
66 }
67 const char *formatStart{static_cast<const char *>(
68 std::memchr(stmt.source.begin(), '(', stmt.source.size()))};
69 parser::CharBlock reporterCharBlock{formatStart, static_cast<std::size_t>(0)};
70 FormatErrorReporter reporter{context_, reporterCharBlock};
71 auto reporterWrapper{[&](const auto &msg) { return reporter.Say(msg); }};
72 switch (context_.GetDefaultKind(TypeCategory::Character)) {
73 case 1: {
74 common::FormatValidator<char> validator{formatStart,
75 stmt.source.size() - (formatStart - stmt.source.begin()),
76 reporterWrapper};
77 validator.Check();
78 break;
79 }
80 case 2: { // TODO: Get this to work.
81 common::FormatValidator<char16_t> validator{
82 /*???*/ nullptr, /*???*/ 0, reporterWrapper};
83 validator.Check();
84 break;
85 }
86 case 4: { // TODO: Get this to work.
87 common::FormatValidator<char32_t> validator{
88 /*???*/ nullptr, /*???*/ 0, reporterWrapper};
89 validator.Check();
90 break;
91 }
92 default:
93 CRASH_NO_CASE;
94 }
95}
96
97void IoChecker::Enter(const parser::ConnectSpec &spec) {
98 // ConnectSpec context FileNameExpr
99 if (std::get_if<parser::FileNameExpr>(&spec.u)) {
100 SetSpecifier(IoSpecKind::File);
101 }
102}
103
104// Ignore trailing spaces (12.5.6.2 p1) and convert to upper case
105static std::string Normalize(const std::string &value) {
106 auto upper{parser::ToUpperCaseLetters(value)};
107 std::size_t lastNonBlank{upper.find_last_not_of(' ')};
108 upper.resize(lastNonBlank == std::string::npos ? 0 : lastNonBlank + 1);
109 return upper;
110}
111
112void IoChecker::Enter(const parser::ConnectSpec::CharExpr &spec) {
113 IoSpecKind specKind{};
114 using ParseKind = parser::ConnectSpec::CharExpr::Kind;
115 switch (std::get<ParseKind>(spec.t)) {
116 case ParseKind::Access:
117 specKind = IoSpecKind::Access;
118 break;
119 case ParseKind::Action:
120 specKind = IoSpecKind::Action;
121 break;
122 case ParseKind::Asynchronous:
123 specKind = IoSpecKind::Asynchronous;
124 break;
125 case ParseKind::Blank:
126 specKind = IoSpecKind::Blank;
127 break;
128 case ParseKind::Decimal:
129 specKind = IoSpecKind::Decimal;
130 break;
131 case ParseKind::Delim:
132 specKind = IoSpecKind::Delim;
133 break;
134 case ParseKind::Encoding:
135 specKind = IoSpecKind::Encoding;
136 break;
137 case ParseKind::Form:
138 specKind = IoSpecKind::Form;
139 break;
140 case ParseKind::Pad:
141 specKind = IoSpecKind::Pad;
142 break;
143 case ParseKind::Position:
144 specKind = IoSpecKind::Position;
145 break;
146 case ParseKind::Round:
147 specKind = IoSpecKind::Round;
148 break;
149 case ParseKind::Sign:
150 specKind = IoSpecKind::Sign;
151 break;
152 case ParseKind::Carriagecontrol:
153 specKind = IoSpecKind::Carriagecontrol;
154 break;
155 case ParseKind::Convert:
156 specKind = IoSpecKind::Convert;
157 break;
158 case ParseKind::Dispose:
159 specKind = IoSpecKind::Dispose;
160 break;
161 }
162 SetSpecifier(specKind);
163 if (const std::optional<std::string> charConst{GetConstExpr<std::string>(
164 std::get<parser::ScalarDefaultCharExpr>(spec.t))}) {
165 std::string s{Normalize(*charConst)};
166 if (specKind == IoSpecKind::Access) {
167 flags_.set(Flag::KnownAccess);
168 flags_.set(Flag::AccessDirect, s == "DIRECT");
169 flags_.set(Flag::AccessStream, s == "STREAM");
170 }
171 CheckStringValue(specKind, *charConst, parser::FindSourceLocation(spec));
172 if (specKind == IoSpecKind::Carriagecontrol &&
173 (s == "FORTRAN" || s == "NONE")) {
174 context_.Say(parser::FindSourceLocation(spec),
175 "Unimplemented %s value '%s'"_err_en_US,
176 parser::ToUpperCaseLetters(common::EnumToString(specKind)),
177 *charConst);
178 }
179 }
180}
181
182void IoChecker::Enter(const parser::ConnectSpec::Newunit &var) {
183 CheckForDefinableVariable(var, "NEWUNIT");
184 SetSpecifier(IoSpecKind::Newunit);
185}
186
187void IoChecker::Enter(const parser::ConnectSpec::Recl &spec) {
188 SetSpecifier(IoSpecKind::Recl);
189 if (const std::optional<std::int64_t> recl{
190 GetConstExpr<std::int64_t>(spec)}) {
191 if (*recl <= 0) {
192 context_.Say(parser::FindSourceLocation(spec),
193 "RECL value (%jd) must be positive"_err_en_US,
194 *recl); // 12.5.6.15
195 }
196 }
197}
198
199void IoChecker::Enter(const parser::EndLabel &) {
200 SetSpecifier(IoSpecKind::End);
201}
202
203void IoChecker::Enter(const parser::EorLabel &) {
204 SetSpecifier(IoSpecKind::Eor);
205}
206
207void IoChecker::Enter(const parser::ErrLabel &) {
208 SetSpecifier(IoSpecKind::Err);
209}
210
211void IoChecker::Enter(const parser::FileUnitNumber &) {
212 SetSpecifier(IoSpecKind::Unit);
213 flags_.set(Flag::NumberUnit);
214}
215
216void IoChecker::Enter(const parser::Format &spec) {
217 SetSpecifier(IoSpecKind::Fmt);
218 flags_.set(Flag::FmtOrNml);
219 common::visit(
220 common::visitors{
221 [&](const parser::Label &) { flags_.set(Flag::LabelFmt); },
222 [&](const parser::Star &) { flags_.set(Flag::StarFmt); },
223 [&](const parser::Expr &format) {
224 const SomeExpr *expr{GetExpr(context_, format)};
225 if (!expr) {
226 return;
227 }
228 auto type{expr->GetType()};
229 if (type && type->category() == TypeCategory::Integer &&
230 type->kind() ==
231 context_.defaultKinds().GetDefaultKind(type->category()) &&
232 expr->Rank() == 0) {
233 flags_.set(Flag::AssignFmt);
234 if (!IsVariable(*expr)) {
235 context_.Say(format.source,
236 "Assigned format label must be a scalar variable"_err_en_US);
237 } else {
238 context_.Warn(common::LanguageFeature::Assign, format.source,
239 "Assigned format labels are deprecated"_port_en_US);
240 }
241 return;
242 }
243 if (type && type->category() != TypeCategory::Character &&
244 (type->category() != TypeCategory::Integer ||
245 expr->Rank() > 0) &&
246 context_.IsEnabled(
247 common::LanguageFeature::NonCharacterFormat)) {
248 // Legacy extension: using non-character variables, typically
249 // DATA-initialized with Hollerith, as format expressions.
250 context_.Warn(common::LanguageFeature::NonCharacterFormat,
251 format.source,
252 "Non-character format expression is not standard"_port_en_US);
253 } else if (!type ||
254 type->kind() !=
255 context_.defaultKinds().GetDefaultKind(type->category())) {
256 context_.Say(format.source,
257 "Format expression must be default character or default scalar integer"_err_en_US);
258 return;
259 }
260 flags_.set(Flag::CharFmt);
261 const std::optional<std::string> constantFormat{
262 GetConstExpr<std::string>(format)};
263 if (!constantFormat) {
264 return;
265 }
266 // validate constant format -- 12.6.2.2
267 bool isFolded{constantFormat->size() != format.source.size() - 2};
268 parser::CharBlock reporterCharBlock{isFolded
269 ? parser::CharBlock{format.source}
270 : parser::CharBlock{format.source.begin() + 1,
271 static_cast<std::size_t>(0)}};
272 FormatErrorReporter reporter{context_, reporterCharBlock};
273 auto reporterWrapper{
274 [&](const auto &msg) { return reporter.Say(msg); }};
275 switch (context_.GetDefaultKind(TypeCategory::Character)) {
276 case 1: {
277 common::FormatValidator<char> validator{constantFormat->c_str(),
278 constantFormat->length(), reporterWrapper, stmt_};
279 validator.Check();
280 break;
281 }
282 case 2: {
283 // TODO: Get this to work. (Maybe combine with earlier instance?)
284 common::FormatValidator<char16_t> validator{
285 /*???*/ nullptr, /*???*/ 0, reporterWrapper, stmt_};
286 validator.Check();
287 break;
288 }
289 case 4: {
290 // TODO: Get this to work. (Maybe combine with earlier instance?)
291 common::FormatValidator<char32_t> validator{
292 /*???*/ nullptr, /*???*/ 0, reporterWrapper, stmt_};
293 validator.Check();
294 break;
295 }
296 default:
297 CRASH_NO_CASE;
298 }
299 },
300 },
301 spec.u);
302}
303
304void IoChecker::Enter(const parser::IdExpr &) { SetSpecifier(IoSpecKind::Id); }
305
306void IoChecker::Enter(const parser::IdVariable &spec) {
307 SetSpecifier(IoSpecKind::Id);
308 const auto *expr{GetExpr(context_, spec)};
309 if (!expr || !expr->GetType()) {
310 return;
311 }
312 CheckForDefinableVariable(spec, "ID");
313 int kind{expr->GetType()->kind()};
314 int defaultKind{context_.GetDefaultKind(TypeCategory::Integer)};
315 if (kind < defaultKind) {
316 context_.Say(
317 "ID kind (%d) is smaller than default INTEGER kind (%d)"_err_en_US,
318 std::move(kind), std::move(defaultKind)); // C1229
319 }
320}
321
322void IoChecker::Enter(const parser::InputItem &spec) {
323 flags_.set(Flag::DataList);
324 const parser::Variable *var{std::get_if<parser::Variable>(&spec.u)};
325 if (!var) {
326 return;
327 }
328 CheckForDefinableVariable(*var, "Input");
329 if (auto expr{AnalyzeExpr(context_, *var)}) {
330 CheckForBadIoType(*expr,
331 flags_.test(Flag::FmtOrNml) ? common::DefinedIo::ReadFormatted
332 : common::DefinedIo::ReadUnformatted,
333 var->GetSource());
334 }
335}
336
337void IoChecker::Enter(const parser::InquireSpec &spec) {
338 // InquireSpec context FileNameExpr
339 if (std::get_if<parser::FileNameExpr>(&spec.u)) {
340 SetSpecifier(IoSpecKind::File);
341 }
342}
343
344void IoChecker::Enter(const parser::InquireSpec::CharVar &spec) {
345 IoSpecKind specKind{};
346 using ParseKind = parser::InquireSpec::CharVar::Kind;
347 switch (std::get<ParseKind>(spec.t)) {
348 case ParseKind::Access:
349 specKind = IoSpecKind::Access;
350 break;
351 case ParseKind::Action:
352 specKind = IoSpecKind::Action;
353 break;
354 case ParseKind::Asynchronous:
355 specKind = IoSpecKind::Asynchronous;
356 break;
357 case ParseKind::Blank:
358 specKind = IoSpecKind::Blank;
359 break;
360 case ParseKind::Decimal:
361 specKind = IoSpecKind::Decimal;
362 break;
363 case ParseKind::Delim:
364 specKind = IoSpecKind::Delim;
365 break;
366 case ParseKind::Direct:
367 specKind = IoSpecKind::Direct;
368 break;
369 case ParseKind::Encoding:
370 specKind = IoSpecKind::Encoding;
371 break;
372 case ParseKind::Form:
373 specKind = IoSpecKind::Form;
374 break;
375 case ParseKind::Formatted:
376 specKind = IoSpecKind::Formatted;
377 break;
378 case ParseKind::Iomsg:
379 specKind = IoSpecKind::Iomsg;
380 break;
381 case ParseKind::Name:
382 specKind = IoSpecKind::Name;
383 break;
384 case ParseKind::Pad:
385 specKind = IoSpecKind::Pad;
386 break;
387 case ParseKind::Position:
388 specKind = IoSpecKind::Position;
389 break;
390 case ParseKind::Read:
391 specKind = IoSpecKind::Read;
392 break;
393 case ParseKind::Readwrite:
394 specKind = IoSpecKind::Readwrite;
395 break;
396 case ParseKind::Round:
397 specKind = IoSpecKind::Round;
398 break;
399 case ParseKind::Sequential:
400 specKind = IoSpecKind::Sequential;
401 break;
402 case ParseKind::Sign:
403 specKind = IoSpecKind::Sign;
404 break;
405 case ParseKind::Status:
406 specKind = IoSpecKind::Status;
407 break;
408 case ParseKind::Stream:
409 specKind = IoSpecKind::Stream;
410 break;
411 case ParseKind::Unformatted:
412 specKind = IoSpecKind::Unformatted;
413 break;
414 case ParseKind::Write:
415 specKind = IoSpecKind::Write;
416 break;
417 case ParseKind::Carriagecontrol:
418 specKind = IoSpecKind::Carriagecontrol;
419 break;
420 case ParseKind::Convert:
421 specKind = IoSpecKind::Convert;
422 break;
423 case ParseKind::Dispose:
424 specKind = IoSpecKind::Dispose;
425 break;
426 }
427 const parser::Variable &var{
428 std::get<parser::ScalarDefaultCharVariable>(spec.t).thing.thing};
429 std::string what{parser::ToUpperCaseLetters(common::EnumToString(specKind))};
430 CheckForDefinableVariable(var, what);
431 WarnOnDeferredLengthCharacterScalar(
432 context_, GetExpr(context_, var), var.GetSource(), what.c_str());
433 SetSpecifier(specKind);
434}
435
436void IoChecker::Enter(const parser::InquireSpec::IntVar &spec) {
437 IoSpecKind specKind{};
438 using ParseKind = parser::InquireSpec::IntVar::Kind;
439 switch (std::get<parser::InquireSpec::IntVar::Kind>(spec.t)) {
440 case ParseKind::Iostat:
441 specKind = IoSpecKind::Iostat;
442 break;
443 case ParseKind::Nextrec:
444 specKind = IoSpecKind::Nextrec;
445 break;
446 case ParseKind::Number:
447 specKind = IoSpecKind::Number;
448 break;
449 case ParseKind::Pos:
450 specKind = IoSpecKind::Pos;
451 break;
452 case ParseKind::Recl:
453 specKind = IoSpecKind::Recl;
454 break;
455 case ParseKind::Size:
456 specKind = IoSpecKind::Size;
457 break;
458 }
459 CheckForDefinableVariable(std::get<parser::ScalarIntVariable>(spec.t),
460 parser::ToUpperCaseLetters(common::EnumToString(specKind)));
461 SetSpecifier(specKind);
462}
463
464void IoChecker::Enter(const parser::InquireSpec::LogVar &spec) {
465 IoSpecKind specKind{};
466 using ParseKind = parser::InquireSpec::LogVar::Kind;
467 switch (std::get<parser::InquireSpec::LogVar::Kind>(spec.t)) {
468 case ParseKind::Exist:
469 specKind = IoSpecKind::Exist;
470 break;
471 case ParseKind::Named:
472 specKind = IoSpecKind::Named;
473 break;
474 case ParseKind::Opened:
475 specKind = IoSpecKind::Opened;
476 break;
477 case ParseKind::Pending:
478 specKind = IoSpecKind::Pending;
479 break;
480 }
481 CheckForDefinableVariable(std::get<parser::ScalarLogicalVariable>(spec.t),
482 parser::ToUpperCaseLetters(common::EnumToString(specKind)));
483 SetSpecifier(specKind);
484}
485
486void IoChecker::Enter(const parser::IoControlSpec &spec) {
487 // IoControlSpec context Name
488 flags_.set(Flag::IoControlList);
489 if (std::holds_alternative<parser::Name>(spec.u)) {
490 SetSpecifier(IoSpecKind::Nml);
491 flags_.set(Flag::FmtOrNml);
492 }
493}
494
495void IoChecker::Enter(const parser::IoControlSpec::Asynchronous &spec) {
496 SetSpecifier(IoSpecKind::Asynchronous);
497 if (const std::optional<std::string> charConst{
498 GetConstExpr<std::string>(spec)}) {
499 flags_.set(Flag::AsynchronousYes, Normalize(*charConst) == "YES");
500 CheckStringValue(IoSpecKind::Asynchronous, *charConst,
501 parser::FindSourceLocation(spec)); // C1223
502 }
503}
504
505void IoChecker::Enter(const parser::IoControlSpec::CharExpr &spec) {
506 IoSpecKind specKind{};
507 using ParseKind = parser::IoControlSpec::CharExpr::Kind;
508 switch (std::get<ParseKind>(spec.t)) {
509 case ParseKind::Advance:
510 specKind = IoSpecKind::Advance;
511 break;
512 case ParseKind::Blank:
513 specKind = IoSpecKind::Blank;
514 break;
515 case ParseKind::Decimal:
516 specKind = IoSpecKind::Decimal;
517 break;
518 case ParseKind::Delim:
519 specKind = IoSpecKind::Delim;
520 break;
521 case ParseKind::Pad:
522 specKind = IoSpecKind::Pad;
523 break;
524 case ParseKind::Round:
525 specKind = IoSpecKind::Round;
526 break;
527 case ParseKind::Sign:
528 specKind = IoSpecKind::Sign;
529 break;
530 }
531 SetSpecifier(specKind);
532 if (const std::optional<std::string> charConst{GetConstExpr<std::string>(
533 std::get<parser::ScalarDefaultCharExpr>(spec.t))}) {
534 if (specKind == IoSpecKind::Advance) {
535 flags_.set(Flag::AdvanceYes, Normalize(*charConst) == "YES");
536 }
537 CheckStringValue(specKind, *charConst, parser::FindSourceLocation(spec));
538 }
539}
540
541void IoChecker::Enter(const parser::IoControlSpec::Pos &) {
542 SetSpecifier(IoSpecKind::Pos);
543}
544
545void IoChecker::Enter(const parser::IoControlSpec::Rec &) {
546 SetSpecifier(IoSpecKind::Rec);
547}
548
549void IoChecker::Enter(const parser::IoControlSpec::Size &var) {
550 CheckForDefinableVariable(var, "SIZE");
551 SetSpecifier(IoSpecKind::Size);
552}
553
554void IoChecker::Enter(const parser::IoUnit &spec) {
555 if (const parser::Variable * var{std::get_if<parser::Variable>(&spec.u)}) {
556 // Only now after generic resolution can it be known whether a function
557 // call appearing as UNIT=f() is an integer scalar external unit number
558 // or a character pointer for internal I/O.
559 const auto *expr{GetExpr(context_, *var)};
560 std::optional<evaluate::DynamicType> dyType;
561 if (expr) {
562 dyType = expr->GetType();
563 }
564 if (dyType && dyType->category() == TypeCategory::Integer) {
565 if (expr->Rank() != 0) {
566 context_.Say(parser::FindSourceLocation(*var),
567 "I/O unit number must be scalar"_err_en_US);
568 }
569 // In the case of an integer unit number variable, rewrite the parse
570 // tree as if the unit had been parsed as a FileUnitNumber in order
571 // to ease lowering.
572 auto &mutableSpec{const_cast<parser::IoUnit &>(spec)};
573 auto &mutableVar{std::get<parser::Variable>(mutableSpec.u)};
574 auto source{mutableVar.GetSource()};
575 auto typedExpr{std::move(mutableVar.typedExpr)};
576 auto newExpr{common::visit(
577 [](auto &&indirection) {
578 return parser::Expr{std::move(indirection)};
579 },
580 std::move(mutableVar.u))};
581 newExpr.source = source;
582 newExpr.typedExpr = std::move(typedExpr);
583 mutableSpec.u = common::Indirection<parser::Expr>{std::move(newExpr)};
584 SetSpecifier(IoSpecKind::Unit);
585 flags_.set(Flag::NumberUnit);
586 } else if (!dyType || dyType->category() != TypeCategory::Character) {
587 SetSpecifier(IoSpecKind::Unit);
588 context_.Say(parser::FindSourceLocation(*var),
589 "I/O unit must be a character variable or a scalar integer expression"_err_en_US);
590 } else { // CHARACTER variable (internal I/O)
591 if (stmt_ == IoStmtKind::Write) {
592 CheckForDefinableVariable(*var, "Internal file");
593 WarnOnDeferredLengthCharacterScalar(
594 context_, expr, var->GetSource(), "Internal file");
595 }
596 if (HasVectorSubscript(*expr)) {
597 context_.Say(parser::FindSourceLocation(*var), // C1201
598 "Internal file must not have a vector subscript"_err_en_US);
599 }
600 SetSpecifier(IoSpecKind::Unit);
601 flags_.set(Flag::InternalUnit);
602 }
603 } else if (std::get_if<parser::Star>(&spec.u)) {
604 SetSpecifier(IoSpecKind::Unit);
605 flags_.set(Flag::StarUnit);
606 } else if (const common::Indirection<parser::Expr> *pexpr{
607 std::get_if<common::Indirection<parser::Expr>>(&spec.u)}) {
608 const auto *expr{GetExpr(context_, *pexpr)};
609 std::optional<evaluate::DynamicType> dyType;
610 if (expr) {
611 dyType = expr->GetType();
612 }
613 if (!expr || !dyType) {
614 context_.Say(parser::FindSourceLocation(*pexpr),
615 "I/O unit must be a character variable or scalar integer expression"_err_en_US);
616 } else if (dyType->category() != TypeCategory::Integer) {
617 context_.Say(parser::FindSourceLocation(*pexpr),
618 "I/O unit must be a character variable or a scalar integer expression, but is an expression of type %s"_err_en_US,
619 parser::ToUpperCaseLetters(dyType->AsFortran()));
620 } else if (expr->Rank() != 0) {
621 context_.Say(parser::FindSourceLocation(*pexpr),
622 "I/O unit number must be scalar"_err_en_US);
623 }
624 SetSpecifier(IoSpecKind::Unit);
625 flags_.set(Flag::NumberUnit);
626 }
627}
628
629void IoChecker::Enter(const parser::MsgVariable &msgVar) {
630 const parser::Variable &var{msgVar.v.thing.thing};
631 if (stmt_ == IoStmtKind::None) {
632 // allocate, deallocate, image control
633 CheckForDefinableVariable(var, "ERRMSG");
634 WarnOnDeferredLengthCharacterScalar(
635 context_, GetExpr(context_, var), var.GetSource(), "ERRMSG=");
636 } else {
637 CheckForDefinableVariable(var, "IOMSG");
638 WarnOnDeferredLengthCharacterScalar(
639 context_, GetExpr(context_, var), var.GetSource(), "IOMSG=");
640 SetSpecifier(IoSpecKind::Iomsg);
641 }
642}
643
644void IoChecker::Enter(const parser::OutputItem &item) {
645 flags_.set(Flag::DataList);
646 if (const auto *x{std::get_if<parser::Expr>(&item.u)}) {
647 if (const auto *expr{GetExpr(context_, *x)}) {
648 if (evaluate::IsBOZLiteral(*expr)) {
649 context_.Say(parser::FindSourceLocation(*x), // C7109
650 "Output item must not be a BOZ literal constant"_err_en_US);
651 } else if (IsProcedure(*expr)) {
652 context_.Say(parser::FindSourceLocation(*x),
653 "Output item must not be a procedure"_err_en_US); // C1233
654 }
655 CheckForBadIoType(*expr,
656 flags_.test(Flag::FmtOrNml) ? common::DefinedIo::WriteFormatted
657 : common::DefinedIo::WriteUnformatted,
658 parser::FindSourceLocation(item));
659 }
660 }
661}
662
663void IoChecker::Enter(const parser::StatusExpr &spec) {
664 SetSpecifier(IoSpecKind::Status);
665 if (const std::optional<std::string> charConst{
666 GetConstExpr<std::string>(spec)}) {
667 // Status values for Open and Close are different.
668 std::string s{Normalize(*charConst)};
669 if (stmt_ == IoStmtKind::Open) {
670 flags_.set(Flag::KnownStatus);
671 flags_.set(Flag::StatusNew, s == "NEW");
672 flags_.set(Flag::StatusReplace, s == "REPLACE");
673 flags_.set(Flag::StatusScratch, s == "SCRATCH");
674 // CheckStringValue compares for OPEN Status string values.
675 CheckStringValue(
676 IoSpecKind::Status, *charConst, parser::FindSourceLocation(spec));
677 return;
678 }
679 CHECK(stmt_ == IoStmtKind::Close);
680 if (s != "DELETE" && s != "KEEP") {
681 context_.Say(parser::FindSourceLocation(spec),
682 "Invalid STATUS value '%s'"_err_en_US, *charConst);
683 }
684 }
685}
686
687void IoChecker::Enter(const parser::StatVariable &var) {
688 if (stmt_ == IoStmtKind::None) {
689 // allocate, deallocate, image control
690 CheckForDefinableVariable(var, "STAT");
691 } else {
692 CheckForDefinableVariable(var, "IOSTAT");
693 SetSpecifier(IoSpecKind::Iostat);
694 }
695}
696
697void IoChecker::Leave(const parser::BackspaceStmt &) {
698 CheckForPureSubprogram();
699 CheckForRequiredSpecifier(
700 flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
701 CheckForUselessIomsg();
702 Done();
703}
704
705void IoChecker::Leave(const parser::CloseStmt &) {
706 CheckForPureSubprogram();
707 CheckForRequiredSpecifier(
708 flags_.test(Flag::NumberUnit), "UNIT number"); // C1208
709 CheckForUselessIomsg();
710 Done();
711}
712
713void IoChecker::Leave(const parser::EndfileStmt &) {
714 CheckForPureSubprogram();
715 CheckForRequiredSpecifier(
716 flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
717 CheckForUselessIomsg();
718 Done();
719}
720
721void IoChecker::Leave(const parser::FlushStmt &) {
722 CheckForPureSubprogram();
723 CheckForRequiredSpecifier(
724 flags_.test(Flag::NumberUnit), "UNIT number"); // C1243
725 CheckForUselessIomsg();
726 Done();
727}
728
729void IoChecker::Leave(const parser::InquireStmt &stmt) {
730 if (std::get_if<std::list<parser::InquireSpec>>(&stmt.u)) {
731 CheckForPureSubprogram();
732 // Inquire by unit or by file (vs. by output list).
733 CheckForRequiredSpecifier(
734 flags_.test(Flag::NumberUnit) || specifierSet_.test(IoSpecKind::File),
735 "UNIT number or FILE"); // C1246
736 CheckForProhibitedSpecifier(IoSpecKind::File, IoSpecKind::Unit); // C1246
737 CheckForRequiredSpecifier(IoSpecKind::Id, IoSpecKind::Pending); // C1248
738 CheckForUselessIomsg();
739 }
740 Done();
741}
742
743void IoChecker::Leave(const parser::OpenStmt &) {
744 CheckForPureSubprogram();
745 CheckForRequiredSpecifier(specifierSet_.test(IoSpecKind::Unit) ||
746 specifierSet_.test(IoSpecKind::Newunit),
747 "UNIT or NEWUNIT"); // C1204, C1205
748 CheckForProhibitedSpecifier(
749 IoSpecKind::Newunit, IoSpecKind::Unit); // C1204, C1205
750 CheckForRequiredSpecifier(flags_.test(Flag::StatusNew), "STATUS='NEW'",
751 IoSpecKind::File); // 12.5.6.10
752 CheckForRequiredSpecifier(flags_.test(Flag::StatusReplace),
753 "STATUS='REPLACE'", IoSpecKind::File); // 12.5.6.10
754 CheckForProhibitedSpecifier(flags_.test(Flag::StatusScratch),
755 "STATUS='SCRATCH'", IoSpecKind::File); // 12.5.6.10
756 if (flags_.test(Flag::KnownStatus)) {
757 CheckForRequiredSpecifier(IoSpecKind::Newunit,
758 specifierSet_.test(IoSpecKind::File) ||
759 flags_.test(Flag::StatusScratch),
760 "FILE or STATUS='SCRATCH'"); // 12.5.6.12
761 } else {
762 CheckForRequiredSpecifier(IoSpecKind::Newunit,
763 specifierSet_.test(IoSpecKind::File) ||
764 specifierSet_.test(IoSpecKind::Status),
765 "FILE or STATUS"); // 12.5.6.12
766 }
767 if (flags_.test(Flag::KnownAccess)) {
768 CheckForRequiredSpecifier(flags_.test(Flag::AccessDirect),
769 "ACCESS='DIRECT'", IoSpecKind::Recl); // 12.5.6.15
770 CheckForProhibitedSpecifier(flags_.test(Flag::AccessStream),
771 "STATUS='STREAM'", IoSpecKind::Recl); // 12.5.6.15
772 }
773 CheckForUselessIomsg();
774 Done();
775}
776
777void IoChecker::Leave(const parser::PrintStmt &) {
778 CheckForPureSubprogram();
779 CheckForUselessIomsg();
780 Done();
781}
782
783static const parser::Name *FindNamelist(
784 const std::list<parser::IoControlSpec> &controls) {
785 for (const auto &control : controls) {
786 if (const parser::Name * namelist{std::get_if<parser::Name>(&control.u)}) {
787 if (namelist->symbol &&
788 namelist->symbol->GetUltimate().has<NamelistDetails>()) {
789 return namelist;
790 }
791 }
792 }
793 return nullptr;
794}
795
796static void CheckForDoVariable(
797 const parser::ReadStmt &readStmt, SemanticsContext &context) {
798 const std::list<parser::InputItem> &items{readStmt.items};
799 for (const auto &item : items) {
800 if (const parser::Variable *
801 variable{std::get_if<parser::Variable>(&item.u)}) {
802 context.CheckIndexVarRedefine(*variable);
803 }
804 }
805}
806
807void IoChecker::Leave(const parser::ReadStmt &readStmt) {
808 if (!flags_.test(Flag::InternalUnit)) {
809 CheckForPureSubprogram();
810 }
811 if (const parser::Name * namelist{FindNamelist(readStmt.controls)}) {
812 if (namelist->symbol) {
813 CheckNamelist(*namelist->symbol, common::DefinedIo::ReadFormatted,
814 namelist->source);
815 }
816 }
817 CheckForDoVariable(readStmt, context_);
818 if (!flags_.test(Flag::IoControlList)) {
819 Done();
820 return;
821 }
822 LeaveReadWrite();
823 CheckForProhibitedSpecifier(IoSpecKind::Delim); // C1212
824 CheckForProhibitedSpecifier(IoSpecKind::Sign); // C1212
825 CheckForProhibitedSpecifier(IoSpecKind::Rec, IoSpecKind::End); // C1220
826 if (specifierSet_.test(IoSpecKind::Size)) {
827 // F'2023 C1214 - allow with a warning
828 if (context_.ShouldWarn(common::LanguageFeature::ListDirectedSize)) {
829 if (specifierSet_.test(IoSpecKind::Nml)) {
830 context_.Say("If NML appears, SIZE should not appear"_port_en_US);
831 } else if (flags_.test(Flag::StarFmt)) {
832 context_.Say("If FMT=* appears, SIZE should not appear"_port_en_US);
833 }
834 }
835 }
836 CheckForRequiredSpecifier(IoSpecKind::Eor,
837 specifierSet_.test(IoSpecKind::Advance) && !flags_.test(Flag::AdvanceYes),
838 "ADVANCE with value 'NO'"); // C1222 + 12.6.2.1p2
839 CheckForRequiredSpecifier(IoSpecKind::Blank, flags_.test(Flag::FmtOrNml),
840 "FMT or NML"); // C1227
841 CheckForRequiredSpecifier(
842 IoSpecKind::Pad, flags_.test(Flag::FmtOrNml), "FMT or NML"); // C1227
843 Done();
844}
845
846void IoChecker::Leave(const parser::RewindStmt &) {
847 CheckForRequiredSpecifier(
848 flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
849 CheckForPureSubprogram();
850 CheckForUselessIomsg();
851 Done();
852}
853
854void IoChecker::Leave(const parser::WaitStmt &) {
855 CheckForRequiredSpecifier(
856 flags_.test(Flag::NumberUnit), "UNIT number"); // C1237
857 CheckForPureSubprogram();
858 CheckForUselessIomsg();
859 Done();
860}
861
862void IoChecker::Leave(const parser::WriteStmt &writeStmt) {
863 if (!flags_.test(Flag::InternalUnit)) {
864 CheckForPureSubprogram();
865 }
866 if (const parser::Name * namelist{FindNamelist(writeStmt.controls)}) {
867 if (namelist->symbol) {
868 CheckNamelist(*namelist->symbol, common::DefinedIo::WriteFormatted,
869 namelist->source);
870 }
871 }
872 LeaveReadWrite();
873 CheckForProhibitedSpecifier(IoSpecKind::Blank); // C1213
874 CheckForProhibitedSpecifier(IoSpecKind::End); // C1213
875 CheckForProhibitedSpecifier(IoSpecKind::Eor); // C1213
876 CheckForProhibitedSpecifier(IoSpecKind::Pad); // C1213
877 CheckForProhibitedSpecifier(IoSpecKind::Size); // C1213
878 CheckForRequiredSpecifier(
879 IoSpecKind::Sign, flags_.test(Flag::FmtOrNml), "FMT or NML"); // C1227
880 CheckForRequiredSpecifier(IoSpecKind::Delim,
881 flags_.test(Flag::StarFmt) || specifierSet_.test(IoSpecKind::Nml),
882 "FMT=* or NML"); // C1228
883 Done();
884}
885
886void IoChecker::LeaveReadWrite() const {
887 CheckForRequiredSpecifier(IoSpecKind::Unit); // C1211
888 CheckForRequiredSpecifier(flags_.test(Flag::InternalUnit),
889 "UNIT=internal-file", flags_.test(Flag::FmtOrNml), "FMT or NML");
890 CheckForProhibitedSpecifier(IoSpecKind::Nml, IoSpecKind::Rec); // C1216
891 CheckForProhibitedSpecifier(IoSpecKind::Nml, IoSpecKind::Fmt); // C1216
892 CheckForProhibitedSpecifier(
893 IoSpecKind::Nml, flags_.test(Flag::DataList), "a data list"); // C1216
894 CheckForProhibitedSpecifier(flags_.test(Flag::InternalUnit),
895 "UNIT=internal-file", IoSpecKind::Pos); // C1219
896 CheckForProhibitedSpecifier(flags_.test(Flag::InternalUnit),
897 "UNIT=internal-file", IoSpecKind::Rec); // C1219
898 CheckForProhibitedSpecifier(
899 flags_.test(Flag::StarUnit), "UNIT=*", IoSpecKind::Pos); // C1219
900 CheckForProhibitedSpecifier(
901 flags_.test(Flag::StarUnit), "UNIT=*", IoSpecKind::Rec); // C1219
902 CheckForProhibitedSpecifier(
903 IoSpecKind::Rec, flags_.test(Flag::StarFmt), "FMT=*"); // C1220
904 CheckForRequiredSpecifier(IoSpecKind::Advance,
905 flags_.test(Flag::CharFmt) || flags_.test(Flag::LabelFmt) ||
906 flags_.test(Flag::AssignFmt),
907 "an explicit format"); // C1221
908 CheckForProhibitedSpecifier(IoSpecKind::Advance,
909 flags_.test(Flag::InternalUnit), "UNIT=internal-file"); // C1221
910 CheckForRequiredSpecifier(flags_.test(Flag::AsynchronousYes),
911 "ASYNCHRONOUS='YES'", flags_.test(Flag::NumberUnit),
912 "UNIT=number"); // C1224
913 CheckForRequiredSpecifier(IoSpecKind::Id, flags_.test(Flag::AsynchronousYes),
914 "ASYNCHRONOUS='YES'"); // C1225
915 CheckForProhibitedSpecifier(IoSpecKind::Pos, IoSpecKind::Rec); // C1226
916 CheckForRequiredSpecifier(IoSpecKind::Decimal, flags_.test(Flag::FmtOrNml),
917 "FMT or NML"); // C1227
918 CheckForRequiredSpecifier(IoSpecKind::Round, flags_.test(Flag::FmtOrNml),
919 "FMT or NML"); // C1227
920 CheckForUselessIomsg();
921}
922
923void IoChecker::SetSpecifier(IoSpecKind specKind) {
924 if (stmt_ == IoStmtKind::None) {
925 // FMT may appear on PRINT statements, which don't have any checks.
926 // [IO]MSG and [IO]STAT parse symbols are shared with non-I/O statements.
927 return;
928 }
929 // C1203, C1207, C1210, C1236, C1239, C1242, C1245
930 if (specifierSet_.test(specKind)) {
931 context_.Say("Duplicate %s specifier"_err_en_US,
932 parser::ToUpperCaseLetters(common::EnumToString(specKind)));
933 }
934 specifierSet_.set(specKind);
935}
936
937void IoChecker::CheckStringValue(IoSpecKind specKind, const std::string &value,
938 const parser::CharBlock &source) const {
939 static std::unordered_map<IoSpecKind, const std::set<std::string>> specValues{
940 {IoSpecKind::Access, {"DIRECT", "SEQUENTIAL", "STREAM"}},
941 {IoSpecKind::Action, {"READ", "READWRITE", "WRITE"}},
942 {IoSpecKind::Advance, {"NO", "YES"}},
943 {IoSpecKind::Asynchronous, {"NO", "YES"}},
944 {IoSpecKind::Blank, {"NULL", "ZERO"}},
945 {IoSpecKind::Decimal, {"COMMA", "POINT"}},
946 {IoSpecKind::Delim, {"APOSTROPHE", "NONE", "QUOTE"}},
947 {IoSpecKind::Encoding, {"DEFAULT", "UTF-8"}},
948 {IoSpecKind::Form, {"FORMATTED", "UNFORMATTED", "BINARY"}},
949 {IoSpecKind::Pad, {"NO", "YES"}},
950 {IoSpecKind::Position, {"APPEND", "ASIS", "REWIND"}},
951 {IoSpecKind::Round,
952 {"COMPATIBLE", "DOWN", "NEAREST", "PROCESSOR_DEFINED", "UP", "ZERO"}},
953 {IoSpecKind::Sign, {"PLUS", "PROCESSOR_DEFINED", "SUPPRESS"}},
954 {IoSpecKind::Status,
955 // Open values; Close values are {"DELETE", "KEEP"}.
956 {"NEW", "OLD", "REPLACE", "SCRATCH", "UNKNOWN"}},
957 {IoSpecKind::Carriagecontrol, {"LIST", "FORTRAN", "NONE"}},
958 {IoSpecKind::Convert, {"BIG_ENDIAN", "LITTLE_ENDIAN", "NATIVE", "SWAP"}},
959 {IoSpecKind::Dispose, {"DELETE", "KEEP"}},
960 };
961 auto upper{Normalize(value)};
962 if (specValues.at(specKind).count(upper) == 0) {
963 if (specKind == IoSpecKind::Access && upper == "APPEND") {
964 context_.Warn(common::LanguageFeature::OpenAccessAppend, source,
965 "ACCESS='%s' interpreted as POSITION='%s'"_port_en_US, value, upper);
966 } else {
967 context_.Say(source, "Invalid %s value '%s'"_err_en_US,
968 parser::ToUpperCaseLetters(common::EnumToString(specKind)), value);
969 }
970 }
971}
972
973// CheckForRequiredSpecifier and CheckForProhibitedSpecifier functions
974// need conditions to check, and string arguments to insert into a message.
975// An IoSpecKind provides both an absence/presence condition and a string
976// argument (its name). A (condition, string) pair provides an arbitrary
977// condition and an arbitrary string.
978
979void IoChecker::CheckForRequiredSpecifier(IoSpecKind specKind) const {
980 if (!specifierSet_.test(specKind)) {
981 context_.Say("%s statement must have a %s specifier"_err_en_US,
982 parser::ToUpperCaseLetters(common::EnumToString(stmt_)),
983 parser::ToUpperCaseLetters(common::EnumToString(specKind)));
984 }
985}
986
987void IoChecker::CheckForRequiredSpecifier(
988 bool condition, const std::string &s) const {
989 if (!condition) {
990 context_.Say("%s statement must have a %s specifier"_err_en_US,
991 parser::ToUpperCaseLetters(common::EnumToString(stmt_)), s);
992 }
993}
994
995void IoChecker::CheckForRequiredSpecifier(
996 IoSpecKind specKind1, IoSpecKind specKind2) const {
997 if (specifierSet_.test(specKind1) && !specifierSet_.test(specKind2)) {
998 context_.Say("If %s appears, %s must also appear"_err_en_US,
999 parser::ToUpperCaseLetters(common::EnumToString(specKind1)),
1000 parser::ToUpperCaseLetters(common::EnumToString(specKind2)));
1001 }
1002}
1003
1004void IoChecker::CheckForRequiredSpecifier(
1005 IoSpecKind specKind, bool condition, const std::string &s) const {
1006 if (specifierSet_.test(specKind) && !condition) {
1007 context_.Say("If %s appears, %s must also appear"_err_en_US,
1008 parser::ToUpperCaseLetters(common::EnumToString(specKind)), s);
1009 }
1010}
1011
1012void IoChecker::CheckForRequiredSpecifier(
1013 bool condition, const std::string &s, IoSpecKind specKind) const {
1014 if (condition && !specifierSet_.test(specKind)) {
1015 context_.Say("If %s appears, %s must also appear"_err_en_US, s,
1016 parser::ToUpperCaseLetters(common::EnumToString(specKind)));
1017 }
1018}
1019
1020void IoChecker::CheckForRequiredSpecifier(bool condition1,
1021 const std::string &s1, bool condition2, const std::string &s2) const {
1022 if (condition1 && !condition2) {
1023 context_.Say("If %s appears, %s must also appear"_err_en_US, s1, s2);
1024 }
1025}
1026
1027void IoChecker::CheckForProhibitedSpecifier(IoSpecKind specKind) const {
1028 if (specifierSet_.test(specKind)) {
1029 context_.Say("%s statement must not have a %s specifier"_err_en_US,
1030 parser::ToUpperCaseLetters(common::EnumToString(stmt_)),
1031 parser::ToUpperCaseLetters(common::EnumToString(specKind)));
1032 }
1033}
1034
1035void IoChecker::CheckForProhibitedSpecifier(
1036 IoSpecKind specKind1, IoSpecKind specKind2) const {
1037 if (specifierSet_.test(specKind1) && specifierSet_.test(specKind2)) {
1038 context_.Say("If %s appears, %s must not appear"_err_en_US,
1039 parser::ToUpperCaseLetters(common::EnumToString(specKind1)),
1040 parser::ToUpperCaseLetters(common::EnumToString(specKind2)));
1041 }
1042}
1043
1044void IoChecker::CheckForProhibitedSpecifier(
1045 IoSpecKind specKind, bool condition, const std::string &s) const {
1046 if (specifierSet_.test(specKind) && condition) {
1047 context_.Say("If %s appears, %s must not appear"_err_en_US,
1048 parser::ToUpperCaseLetters(common::EnumToString(specKind)), s);
1049 }
1050}
1051
1052void IoChecker::CheckForProhibitedSpecifier(
1053 bool condition, const std::string &s, IoSpecKind specKind) const {
1054 if (condition && specifierSet_.test(specKind)) {
1055 context_.Say("If %s appears, %s must not appear"_err_en_US, s,
1056 parser::ToUpperCaseLetters(common::EnumToString(specKind)));
1057 }
1058}
1059
1060template <typename A>
1061void IoChecker::CheckForDefinableVariable(
1062 const A &variable, const std::string &s) const {
1063 if (const auto *var{parser::Unwrap<parser::Variable>(variable)}) {
1064 if (auto expr{AnalyzeExpr(context_, *var)}) {
1065 auto at{var->GetSource()};
1066 if (auto whyNot{WhyNotDefinable(at, context_.FindScope(at),
1067 DefinabilityFlags{DefinabilityFlag::VectorSubscriptIsOk},
1068 *expr)}) {
1069 if (whyNot->IsFatal()) {
1070 const Symbol *base{GetFirstSymbol(*expr)};
1071 context_
1072 .Say(at, "%s variable '%s' is not definable"_err_en_US, s,
1073 (base ? base->name() : at).ToString())
1074 .Attach(
1075 std::move(whyNot->set_severity(parser::Severity::Because)));
1076 } else {
1077 context_.Say(std::move(*whyNot));
1078 }
1079 }
1080 }
1081 }
1082}
1083
1084void IoChecker::CheckForPureSubprogram() const { // C1597
1085 CHECK(context_.location());
1086 const Scope &scope{context_.FindScope(*context_.location())};
1087 if (FindPureProcedureContaining(scope)) {
1088 context_.Say("External I/O is not allowed in a pure subprogram"_err_en_US);
1089 }
1090}
1091
1092void IoChecker::CheckForUselessIomsg() const {
1093 if (specifierSet_.test(IoSpecKind::Iomsg) &&
1094 !specifierSet_.test(IoSpecKind::Err) &&
1095 !specifierSet_.test(IoSpecKind::Iostat) &&
1096 context_.ShouldWarn(common::UsageWarning::UselessIomsg)) {
1097 context_.Say("IOMSG= is useless without either ERR= or IOSTAT="_warn_en_US);
1098 }
1099}
1100
1101// Seeks out an allocatable or pointer ultimate component that is not
1102// nested in a nonallocatable/nonpointer component with a specific
1103// defined I/O procedure.
1104static const Symbol *FindUnsafeIoDirectComponent(common::DefinedIo which,
1105 const DerivedTypeSpec &derived, const Scope &scope) {
1106 if (HasDefinedIo(which, derived, &scope)) {
1107 return nullptr;
1108 }
1109 if (const Scope * dtScope{derived.scope()}) {
1110 for (const auto &pair : *dtScope) {
1111 const Symbol &symbol{*pair.second};
1112 if (IsAllocatableOrPointer(symbol)) {
1113 return &symbol;
1114 }
1115 if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
1116 if (const DeclTypeSpec * type{details->type()}) {
1117 if (type->category() == DeclTypeSpec::Category::TypeDerived) {
1118 const DerivedTypeSpec &componentDerived{type->derivedTypeSpec()};
1119 if (const Symbol *
1120 bad{FindUnsafeIoDirectComponent(
1121 which, componentDerived, scope)}) {
1122 return bad;
1123 }
1124 }
1125 }
1126 }
1127 }
1128 }
1129 return nullptr;
1130}
1131
1132// For a type that does not have a defined I/O subroutine, finds a direct
1133// component that is a witness to an accessibility violation outside the module
1134// in which the type was defined.
1135static const Symbol *FindInaccessibleComponent(common::DefinedIo which,
1136 const DerivedTypeSpec &derived, const Scope &scope) {
1137 if (const Scope * dtScope{derived.scope()}) {
1138 if (const Scope * module{FindModuleContaining(*dtScope)}) {
1139 for (const auto &pair : *dtScope) {
1140 const Symbol &symbol{*pair.second};
1141 if (IsAllocatableOrPointer(symbol)) {
1142 continue; // already an error
1143 }
1144 if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
1145 const DerivedTypeSpec *componentDerived{nullptr};
1146 if (const DeclTypeSpec * type{details->type()}) {
1147 if (type->category() == DeclTypeSpec::Category::TypeDerived) {
1148 componentDerived = &type->derivedTypeSpec();
1149 }
1150 }
1151 if (componentDerived &&
1152 HasDefinedIo(which, *componentDerived, &scope)) {
1153 continue; // this component and its descendents are fine
1154 }
1155 if (symbol.attrs().test(Attr::PRIVATE) &&
1156 !symbol.test(Symbol::Flag::ParentComp)) {
1157 if (!DoesScopeContain(module, scope)) {
1158 return &symbol;
1159 }
1160 }
1161 if (componentDerived) {
1162 if (const Symbol *
1163 bad{FindInaccessibleComponent(
1164 which, *componentDerived, scope)}) {
1165 return bad;
1166 }
1167 }
1168 }
1169 }
1170 }
1171 }
1172 return nullptr;
1173}
1174
1175// Fortran 2018, 12.6.3 paragraphs 5 & 7
1176parser::Message *IoChecker::CheckForBadIoType(const evaluate::DynamicType &type,
1177 common::DefinedIo which, parser::CharBlock where) const {
1178 if (type.IsUnlimitedPolymorphic()) {
1179 return &context_.Say(
1180 where, "I/O list item may not be unlimited polymorphic"_err_en_US);
1181 } else if (type.category() == TypeCategory::Derived) {
1182 const auto &derived{type.GetDerivedTypeSpec()};
1183 const Scope &scope{context_.FindScope(where)};
1184 if (const Symbol *
1185 bad{FindUnsafeIoDirectComponent(which, derived, scope)}) {
1186 return &context_.SayWithDecl(*bad, where,
1187 "Derived type '%s' in I/O cannot have an allocatable or pointer direct component '%s' unless using defined I/O"_err_en_US,
1188 derived.name(), bad->name());
1189 }
1190 if (!HasDefinedIo(which, derived, &scope)) {
1191 if (type.IsPolymorphic()) {
1192 return &context_.Say(where,
1193 "Derived type '%s' in I/O may not be polymorphic unless using defined I/O"_err_en_US,
1194 derived.name());
1195 }
1196 if ((IsBuiltinDerivedType(&derived, "c_ptr") ||
1197 IsBuiltinDerivedType(&derived, "c_devptr")) &&
1198 !context_.ShouldWarn(common::LanguageFeature::PrintCptr)) {
1199 // Bypass the check below for c_ptr and c_devptr.
1200 return nullptr;
1201 }
1202 if (const Symbol *
1203 bad{FindInaccessibleComponent(which, derived, scope)}) {
1204 return &context_.Say(where,
1205 "I/O of the derived type '%s' may not be performed without defined I/O in a scope in which a direct component like '%s' is inaccessible"_err_en_US,
1206 derived.name(), bad->name());
1207 }
1208 }
1209 }
1210 return nullptr;
1211}
1212
1213void IoChecker::CheckForBadIoType(const SomeExpr &expr, common::DefinedIo which,
1214 parser::CharBlock where) const {
1215 if (auto type{expr.GetType()}) {
1216 CheckForBadIoType(*type, which, where);
1217 }
1218}
1219
1220parser::Message *IoChecker::CheckForBadIoType(const Symbol &symbol,
1221 common::DefinedIo which, parser::CharBlock where) const {
1222 if (auto type{evaluate::DynamicType::From(symbol)}) {
1223 if (auto *msg{CheckForBadIoType(*type, which, where)}) {
1224 evaluate::AttachDeclaration(*msg, symbol);
1225 return msg;
1226 }
1227 }
1228 return nullptr;
1229}
1230
1231void IoChecker::CheckNamelist(const Symbol &namelist, common::DefinedIo which,
1232 parser::CharBlock namelistLocation) const {
1233 if (!context_.HasError(namelist)) {
1234 const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
1235 for (const Symbol &object : details.objects()) {
1236 context_.CheckIndexVarRedefine(namelistLocation, object);
1237 if (auto *msg{CheckForBadIoType(object, which, namelistLocation)}) {
1238 evaluate::AttachDeclaration(*msg, namelist);
1239 } else if (which == common::DefinedIo::ReadFormatted) {
1240 if (auto why{WhyNotDefinable(namelistLocation, namelist.owner(),
1241 DefinabilityFlags{}, object)}) {
1242 context_
1243 .Say(namelistLocation,
1244 "NAMELIST input group must not contain undefinable item '%s'"_err_en_US,
1245 object.name())
1246 .Attach(std::move(why->set_severity(parser::Severity::Because)));
1247 context_.SetError(namelist);
1248 }
1249 }
1250 }
1251 }
1252}
1253
1254} // namespace Fortran::semantics
1255

source code of flang/lib/Semantics/check-io.cpp