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 "flang/Common/format.h"
11 #include "flang/Evaluate/tools.h"
12 #include "flang/Parser/tools.h"
13 #include "flang/Semantics/expression.h"
14 #include "flang/Semantics/tools.h"
15 #include <unordered_map>
16 
17 namespace Fortran::semantics {
18 
19 // TODO: C1234, C1235 -- defined I/O constraints
20 
21 class FormatErrorReporter {
22 public:
FormatErrorReporter(SemanticsContext & context,const parser::CharBlock & formatCharBlock,int errorAllowance=3)23   FormatErrorReporter(SemanticsContext &context,
24       const parser::CharBlock &formatCharBlock, int errorAllowance = 3)
25       : context_{context}, formatCharBlock_{formatCharBlock},
26         errorAllowance_{errorAllowance} {}
27 
28   bool Say(const common::FormatMessage &);
29 
30 private:
31   SemanticsContext &context_;
32   const parser::CharBlock &formatCharBlock_;
33   int errorAllowance_; // initialized to maximum number of errors to report
34 };
35 
Say(const common::FormatMessage & msg)36 bool FormatErrorReporter::Say(const common::FormatMessage &msg) {
37   if (!msg.isError && !context_.warnOnNonstandardUsage()) {
38     return false;
39   }
40   parser::MessageFormattedText text{
41       parser::MessageFixedText{msg.text, strlen(msg.text),
42           msg.isError ? parser::Severity::Error : parser::Severity::Warning},
43       msg.arg};
44   if (formatCharBlock_.size()) {
45     // The input format is a folded expression.  Error markers span the full
46     // original unfolded expression in formatCharBlock_.
47     context_.Say(formatCharBlock_, text);
48   } else {
49     // The input format is a source expression.  Error markers have an offset
50     // and length relative to the beginning of formatCharBlock_.
51     parser::CharBlock messageCharBlock{
52         parser::CharBlock(formatCharBlock_.begin() + msg.offset, msg.length)};
53     context_.Say(messageCharBlock, text);
54   }
55   return msg.isError && --errorAllowance_ <= 0;
56 }
57 
Enter(const parser::Statement<common::Indirection<parser::FormatStmt>> & stmt)58 void IoChecker::Enter(
59     const parser::Statement<common::Indirection<parser::FormatStmt>> &stmt) {
60   if (!stmt.label) {
61     context_.Say("Format statement must be labeled"_err_en_US); // C1301
62   }
63   const char *formatStart{static_cast<const char *>(
64       std::memchr(stmt.source.begin(), '(', stmt.source.size()))};
65   parser::CharBlock reporterCharBlock{formatStart, static_cast<std::size_t>(0)};
66   FormatErrorReporter reporter{context_, reporterCharBlock};
67   auto reporterWrapper{[&](const auto &msg) { return reporter.Say(msg); }};
68   switch (context_.GetDefaultKind(TypeCategory::Character)) {
69   case 1: {
70     common::FormatValidator<char> validator{formatStart,
71         stmt.source.size() - (formatStart - stmt.source.begin()),
72         reporterWrapper};
73     validator.Check();
74     break;
75   }
76   case 2: { // TODO: Get this to work.
77     common::FormatValidator<char16_t> validator{
78         /*???*/ nullptr, /*???*/ 0, reporterWrapper};
79     validator.Check();
80     break;
81   }
82   case 4: { // TODO: Get this to work.
83     common::FormatValidator<char32_t> validator{
84         /*???*/ nullptr, /*???*/ 0, reporterWrapper};
85     validator.Check();
86     break;
87   }
88   default:
89     CRASH_NO_CASE;
90   }
91 }
92 
Enter(const parser::ConnectSpec & spec)93 void IoChecker::Enter(const parser::ConnectSpec &spec) {
94   // ConnectSpec context FileNameExpr
95   if (std::get_if<parser::FileNameExpr>(&spec.u)) {
96     SetSpecifier(IoSpecKind::File);
97   }
98 }
99 
100 // Ignore trailing spaces (12.5.6.2 p1) and convert to upper case
Normalize(const std::string & value)101 static std::string Normalize(const std::string &value) {
102   auto upper{parser::ToUpperCaseLetters(value)};
103   std::size_t lastNonBlank{upper.find_last_not_of(" ")};
104   upper.resize(lastNonBlank == std::string::npos ? 0 : lastNonBlank + 1);
105   return upper;
106 }
107 
Enter(const parser::ConnectSpec::CharExpr & spec)108 void IoChecker::Enter(const parser::ConnectSpec::CharExpr &spec) {
109   IoSpecKind specKind{};
110   using ParseKind = parser::ConnectSpec::CharExpr::Kind;
111   switch (std::get<ParseKind>(spec.t)) {
112   case ParseKind::Access:
113     specKind = IoSpecKind::Access;
114     break;
115   case ParseKind::Action:
116     specKind = IoSpecKind::Action;
117     break;
118   case ParseKind::Asynchronous:
119     specKind = IoSpecKind::Asynchronous;
120     break;
121   case ParseKind::Blank:
122     specKind = IoSpecKind::Blank;
123     break;
124   case ParseKind::Decimal:
125     specKind = IoSpecKind::Decimal;
126     break;
127   case ParseKind::Delim:
128     specKind = IoSpecKind::Delim;
129     break;
130   case ParseKind::Encoding:
131     specKind = IoSpecKind::Encoding;
132     break;
133   case ParseKind::Form:
134     specKind = IoSpecKind::Form;
135     break;
136   case ParseKind::Pad:
137     specKind = IoSpecKind::Pad;
138     break;
139   case ParseKind::Position:
140     specKind = IoSpecKind::Position;
141     break;
142   case ParseKind::Round:
143     specKind = IoSpecKind::Round;
144     break;
145   case ParseKind::Sign:
146     specKind = IoSpecKind::Sign;
147     break;
148   case ParseKind::Carriagecontrol:
149     specKind = IoSpecKind::Carriagecontrol;
150     break;
151   case ParseKind::Convert:
152     specKind = IoSpecKind::Convert;
153     break;
154   case ParseKind::Dispose:
155     specKind = IoSpecKind::Dispose;
156     break;
157   }
158   SetSpecifier(specKind);
159   if (const std::optional<std::string> charConst{GetConstExpr<std::string>(
160           std::get<parser::ScalarDefaultCharExpr>(spec.t))}) {
161     std::string s{Normalize(*charConst)};
162     if (specKind == IoSpecKind::Access) {
163       flags_.set(Flag::KnownAccess);
164       flags_.set(Flag::AccessDirect, s == "DIRECT");
165       flags_.set(Flag::AccessStream, s == "STREAM");
166     }
167     CheckStringValue(specKind, *charConst, parser::FindSourceLocation(spec));
168     if (specKind == IoSpecKind::Carriagecontrol &&
169         (s == "FORTRAN" || s == "NONE")) {
170       context_.Say(parser::FindSourceLocation(spec),
171           "Unimplemented %s value '%s'"_err_en_US,
172           parser::ToUpperCaseLetters(common::EnumToString(specKind)),
173           *charConst);
174     }
175   }
176 }
177 
Enter(const parser::ConnectSpec::Newunit & var)178 void IoChecker::Enter(const parser::ConnectSpec::Newunit &var) {
179   CheckForDefinableVariable(var, "NEWUNIT");
180   SetSpecifier(IoSpecKind::Newunit);
181 }
182 
Enter(const parser::ConnectSpec::Recl & spec)183 void IoChecker::Enter(const parser::ConnectSpec::Recl &spec) {
184   SetSpecifier(IoSpecKind::Recl);
185   if (const std::optional<std::int64_t> recl{
186           GetConstExpr<std::int64_t>(spec)}) {
187     if (*recl <= 0) {
188       context_.Say(parser::FindSourceLocation(spec),
189           "RECL value (%jd) must be positive"_err_en_US,
190           *recl); // 12.5.6.15
191     }
192   }
193 }
194 
Enter(const parser::EndLabel &)195 void IoChecker::Enter(const parser::EndLabel &) {
196   SetSpecifier(IoSpecKind::End);
197 }
198 
Enter(const parser::EorLabel &)199 void IoChecker::Enter(const parser::EorLabel &) {
200   SetSpecifier(IoSpecKind::Eor);
201 }
202 
Enter(const parser::ErrLabel &)203 void IoChecker::Enter(const parser::ErrLabel &) {
204   SetSpecifier(IoSpecKind::Err);
205 }
206 
Enter(const parser::FileUnitNumber &)207 void IoChecker::Enter(const parser::FileUnitNumber &) {
208   SetSpecifier(IoSpecKind::Unit);
209   flags_.set(Flag::NumberUnit);
210 }
211 
Enter(const parser::Format & spec)212 void IoChecker::Enter(const parser::Format &spec) {
213   SetSpecifier(IoSpecKind::Fmt);
214   flags_.set(Flag::FmtOrNml);
215   common::visit(
216       common::visitors{
217           [&](const parser::Label &) { flags_.set(Flag::LabelFmt); },
218           [&](const parser::Star &) { flags_.set(Flag::StarFmt); },
219           [&](const parser::Expr &format) {
220             const SomeExpr *expr{GetExpr(context_, format)};
221             if (!expr) {
222               return;
223             }
224             auto type{expr->GetType()};
225             if (type && type->category() == TypeCategory::Integer &&
226                 type->kind() ==
227                     context_.defaultKinds().GetDefaultKind(type->category()) &&
228                 expr->Rank() == 0) {
229               flags_.set(Flag::AssignFmt);
230               if (!IsVariable(*expr)) {
231                 context_.Say(format.source,
232                     "Assigned format label must be a scalar variable"_err_en_US);
233               }
234               return;
235             }
236             if (type && type->category() != TypeCategory::Character &&
237                 (type->category() != TypeCategory::Integer ||
238                     expr->Rank() > 0) &&
239                 context_.IsEnabled(
240                     common::LanguageFeature::NonCharacterFormat)) {
241               // Legacy extension: using non-character variables, typically
242               // DATA-initialized with Hollerith, as format expressions.
243               if (context_.ShouldWarn(
244                       common::LanguageFeature::NonCharacterFormat)) {
245                 context_.Say(format.source,
246                     "Non-character format expression is not standard"_port_en_US);
247               }
248             } else if (!type ||
249                 type->kind() !=
250                     context_.defaultKinds().GetDefaultKind(type->category())) {
251               context_.Say(format.source,
252                   "Format expression must be default character or default scalar integer"_err_en_US);
253               return;
254             }
255             if (expr->Rank() > 0 &&
256                 !IsSimplyContiguous(*expr, context_.foldingContext())) {
257               // The runtime APIs don't allow arbitrary descriptors for formats.
258               context_.Say(format.source,
259                   "Format expression must be a simply contiguous array if not scalar"_err_en_US);
260               return;
261             }
262             flags_.set(Flag::CharFmt);
263             const std::optional<std::string> constantFormat{
264                 GetConstExpr<std::string>(format)};
265             if (!constantFormat) {
266               return;
267             }
268             // validate constant format -- 12.6.2.2
269             bool isFolded{constantFormat->size() != format.source.size() - 2};
270             parser::CharBlock reporterCharBlock{isFolded
271                     ? parser::CharBlock{format.source}
272                     : parser::CharBlock{format.source.begin() + 1,
273                           static_cast<std::size_t>(0)}};
274             FormatErrorReporter reporter{context_, reporterCharBlock};
275             auto reporterWrapper{
276                 [&](const auto &msg) { return reporter.Say(msg); }};
277             switch (context_.GetDefaultKind(TypeCategory::Character)) {
278             case 1: {
279               common::FormatValidator<char> validator{constantFormat->c_str(),
280                   constantFormat->length(), reporterWrapper, stmt_};
281               validator.Check();
282               break;
283             }
284             case 2: {
285               // TODO: Get this to work.  (Maybe combine with earlier instance?)
286               common::FormatValidator<char16_t> validator{
287                   /*???*/ nullptr, /*???*/ 0, reporterWrapper, stmt_};
288               validator.Check();
289               break;
290             }
291             case 4: {
292               // TODO: Get this to work.  (Maybe combine with earlier instance?)
293               common::FormatValidator<char32_t> validator{
294                   /*???*/ nullptr, /*???*/ 0, reporterWrapper, stmt_};
295               validator.Check();
296               break;
297             }
298             default:
299               CRASH_NO_CASE;
300             }
301           },
302       },
303       spec.u);
304 }
305 
Enter(const parser::IdExpr &)306 void IoChecker::Enter(const parser::IdExpr &) { SetSpecifier(IoSpecKind::Id); }
307 
Enter(const parser::IdVariable & spec)308 void IoChecker::Enter(const parser::IdVariable &spec) {
309   SetSpecifier(IoSpecKind::Id);
310   const auto *expr{GetExpr(context_, spec)};
311   if (!expr || !expr->GetType()) {
312     return;
313   }
314   CheckForDefinableVariable(spec, "ID");
315   int kind{expr->GetType()->kind()};
316   int defaultKind{context_.GetDefaultKind(TypeCategory::Integer)};
317   if (kind < defaultKind) {
318     context_.Say(
319         "ID kind (%d) is smaller than default INTEGER kind (%d)"_err_en_US,
320         std::move(kind), std::move(defaultKind)); // C1229
321   }
322 }
323 
Enter(const parser::InputItem & spec)324 void IoChecker::Enter(const parser::InputItem &spec) {
325   flags_.set(Flag::DataList);
326   const parser::Variable *var{std::get_if<parser::Variable>(&spec.u)};
327   if (!var) {
328     return;
329   }
330   CheckForDefinableVariable(*var, "Input");
331   if (auto expr{AnalyzeExpr(context_, *var)}) {
332     CheckForBadIoComponent(*expr,
333         flags_.test(Flag::FmtOrNml) ? GenericKind::DefinedIo::ReadFormatted
334                                     : GenericKind::DefinedIo::ReadUnformatted,
335         var->GetSource());
336   }
337 }
338 
Enter(const parser::InquireSpec & spec)339 void IoChecker::Enter(const parser::InquireSpec &spec) {
340   // InquireSpec context FileNameExpr
341   if (std::get_if<parser::FileNameExpr>(&spec.u)) {
342     SetSpecifier(IoSpecKind::File);
343   }
344 }
345 
Enter(const parser::InquireSpec::CharVar & spec)346 void IoChecker::Enter(const parser::InquireSpec::CharVar &spec) {
347   IoSpecKind specKind{};
348   using ParseKind = parser::InquireSpec::CharVar::Kind;
349   switch (std::get<ParseKind>(spec.t)) {
350   case ParseKind::Access:
351     specKind = IoSpecKind::Access;
352     break;
353   case ParseKind::Action:
354     specKind = IoSpecKind::Action;
355     break;
356   case ParseKind::Asynchronous:
357     specKind = IoSpecKind::Asynchronous;
358     break;
359   case ParseKind::Blank:
360     specKind = IoSpecKind::Blank;
361     break;
362   case ParseKind::Decimal:
363     specKind = IoSpecKind::Decimal;
364     break;
365   case ParseKind::Delim:
366     specKind = IoSpecKind::Delim;
367     break;
368   case ParseKind::Direct:
369     specKind = IoSpecKind::Direct;
370     break;
371   case ParseKind::Encoding:
372     specKind = IoSpecKind::Encoding;
373     break;
374   case ParseKind::Form:
375     specKind = IoSpecKind::Form;
376     break;
377   case ParseKind::Formatted:
378     specKind = IoSpecKind::Formatted;
379     break;
380   case ParseKind::Iomsg:
381     specKind = IoSpecKind::Iomsg;
382     break;
383   case ParseKind::Name:
384     specKind = IoSpecKind::Name;
385     break;
386   case ParseKind::Pad:
387     specKind = IoSpecKind::Pad;
388     break;
389   case ParseKind::Position:
390     specKind = IoSpecKind::Position;
391     break;
392   case ParseKind::Read:
393     specKind = IoSpecKind::Read;
394     break;
395   case ParseKind::Readwrite:
396     specKind = IoSpecKind::Readwrite;
397     break;
398   case ParseKind::Round:
399     specKind = IoSpecKind::Round;
400     break;
401   case ParseKind::Sequential:
402     specKind = IoSpecKind::Sequential;
403     break;
404   case ParseKind::Sign:
405     specKind = IoSpecKind::Sign;
406     break;
407   case ParseKind::Status:
408     specKind = IoSpecKind::Status;
409     break;
410   case ParseKind::Stream:
411     specKind = IoSpecKind::Stream;
412     break;
413   case ParseKind::Unformatted:
414     specKind = IoSpecKind::Unformatted;
415     break;
416   case ParseKind::Write:
417     specKind = IoSpecKind::Write;
418     break;
419   case ParseKind::Carriagecontrol:
420     specKind = IoSpecKind::Carriagecontrol;
421     break;
422   case ParseKind::Convert:
423     specKind = IoSpecKind::Convert;
424     break;
425   case ParseKind::Dispose:
426     specKind = IoSpecKind::Dispose;
427     break;
428   }
429   CheckForDefinableVariable(std::get<parser::ScalarDefaultCharVariable>(spec.t),
430       parser::ToUpperCaseLetters(common::EnumToString(specKind)));
431   SetSpecifier(specKind);
432 }
433 
Enter(const parser::InquireSpec::IntVar & spec)434 void IoChecker::Enter(const parser::InquireSpec::IntVar &spec) {
435   IoSpecKind specKind{};
436   using ParseKind = parser::InquireSpec::IntVar::Kind;
437   switch (std::get<parser::InquireSpec::IntVar::Kind>(spec.t)) {
438   case ParseKind::Iostat:
439     specKind = IoSpecKind::Iostat;
440     break;
441   case ParseKind::Nextrec:
442     specKind = IoSpecKind::Nextrec;
443     break;
444   case ParseKind::Number:
445     specKind = IoSpecKind::Number;
446     break;
447   case ParseKind::Pos:
448     specKind = IoSpecKind::Pos;
449     break;
450   case ParseKind::Recl:
451     specKind = IoSpecKind::Recl;
452     break;
453   case ParseKind::Size:
454     specKind = IoSpecKind::Size;
455     break;
456   }
457   CheckForDefinableVariable(std::get<parser::ScalarIntVariable>(spec.t),
458       parser::ToUpperCaseLetters(common::EnumToString(specKind)));
459   SetSpecifier(specKind);
460 }
461 
Enter(const parser::InquireSpec::LogVar & spec)462 void IoChecker::Enter(const parser::InquireSpec::LogVar &spec) {
463   IoSpecKind specKind{};
464   using ParseKind = parser::InquireSpec::LogVar::Kind;
465   switch (std::get<parser::InquireSpec::LogVar::Kind>(spec.t)) {
466   case ParseKind::Exist:
467     specKind = IoSpecKind::Exist;
468     break;
469   case ParseKind::Named:
470     specKind = IoSpecKind::Named;
471     break;
472   case ParseKind::Opened:
473     specKind = IoSpecKind::Opened;
474     break;
475   case ParseKind::Pending:
476     specKind = IoSpecKind::Pending;
477     break;
478   }
479   SetSpecifier(specKind);
480 }
481 
Enter(const parser::IoControlSpec & spec)482 void IoChecker::Enter(const parser::IoControlSpec &spec) {
483   // IoControlSpec context Name
484   flags_.set(Flag::IoControlList);
485   if (std::holds_alternative<parser::Name>(spec.u)) {
486     SetSpecifier(IoSpecKind::Nml);
487     flags_.set(Flag::FmtOrNml);
488   }
489 }
490 
Enter(const parser::IoControlSpec::Asynchronous & spec)491 void IoChecker::Enter(const parser::IoControlSpec::Asynchronous &spec) {
492   SetSpecifier(IoSpecKind::Asynchronous);
493   if (const std::optional<std::string> charConst{
494           GetConstExpr<std::string>(spec)}) {
495     flags_.set(Flag::AsynchronousYes, Normalize(*charConst) == "YES");
496     CheckStringValue(IoSpecKind::Asynchronous, *charConst,
497         parser::FindSourceLocation(spec)); // C1223
498   }
499 }
500 
Enter(const parser::IoControlSpec::CharExpr & spec)501 void IoChecker::Enter(const parser::IoControlSpec::CharExpr &spec) {
502   IoSpecKind specKind{};
503   using ParseKind = parser::IoControlSpec::CharExpr::Kind;
504   switch (std::get<ParseKind>(spec.t)) {
505   case ParseKind::Advance:
506     specKind = IoSpecKind::Advance;
507     break;
508   case ParseKind::Blank:
509     specKind = IoSpecKind::Blank;
510     break;
511   case ParseKind::Decimal:
512     specKind = IoSpecKind::Decimal;
513     break;
514   case ParseKind::Delim:
515     specKind = IoSpecKind::Delim;
516     break;
517   case ParseKind::Pad:
518     specKind = IoSpecKind::Pad;
519     break;
520   case ParseKind::Round:
521     specKind = IoSpecKind::Round;
522     break;
523   case ParseKind::Sign:
524     specKind = IoSpecKind::Sign;
525     break;
526   }
527   SetSpecifier(specKind);
528   if (const std::optional<std::string> charConst{GetConstExpr<std::string>(
529           std::get<parser::ScalarDefaultCharExpr>(spec.t))}) {
530     if (specKind == IoSpecKind::Advance) {
531       flags_.set(Flag::AdvanceYes, Normalize(*charConst) == "YES");
532     }
533     CheckStringValue(specKind, *charConst, parser::FindSourceLocation(spec));
534   }
535 }
536 
Enter(const parser::IoControlSpec::Pos &)537 void IoChecker::Enter(const parser::IoControlSpec::Pos &) {
538   SetSpecifier(IoSpecKind::Pos);
539 }
540 
Enter(const parser::IoControlSpec::Rec &)541 void IoChecker::Enter(const parser::IoControlSpec::Rec &) {
542   SetSpecifier(IoSpecKind::Rec);
543 }
544 
Enter(const parser::IoControlSpec::Size & var)545 void IoChecker::Enter(const parser::IoControlSpec::Size &var) {
546   CheckForDefinableVariable(var, "SIZE");
547   SetSpecifier(IoSpecKind::Size);
548 }
549 
Enter(const parser::IoUnit & spec)550 void IoChecker::Enter(const parser::IoUnit &spec) {
551   if (const parser::Variable * var{std::get_if<parser::Variable>(&spec.u)}) {
552     if (stmt_ == IoStmtKind::Write) {
553       CheckForDefinableVariable(*var, "Internal file");
554     }
555     if (const auto *expr{GetExpr(context_, *var)}) {
556       if (HasVectorSubscript(*expr)) {
557         context_.Say(parser::FindSourceLocation(*var), // C1201
558             "Internal file must not have a vector subscript"_err_en_US);
559       } else if (!ExprTypeKindIsDefault(*expr, context_)) {
560         // This may be too restrictive; other kinds may be valid.
561         context_.Say(parser::FindSourceLocation(*var), // C1202
562             "Invalid character kind for an internal file variable"_err_en_US);
563       }
564     }
565     SetSpecifier(IoSpecKind::Unit);
566     flags_.set(Flag::InternalUnit);
567   } else if (std::get_if<parser::Star>(&spec.u)) {
568     SetSpecifier(IoSpecKind::Unit);
569     flags_.set(Flag::StarUnit);
570   }
571 }
572 
Enter(const parser::MsgVariable & var)573 void IoChecker::Enter(const parser::MsgVariable &var) {
574   if (stmt_ == IoStmtKind::None) {
575     // allocate, deallocate, image control
576     CheckForDefinableVariable(var, "ERRMSG");
577     return;
578   }
579   CheckForDefinableVariable(var, "IOMSG");
580   SetSpecifier(IoSpecKind::Iomsg);
581 }
582 
Enter(const parser::OutputItem & item)583 void IoChecker::Enter(const parser::OutputItem &item) {
584   flags_.set(Flag::DataList);
585   if (const auto *x{std::get_if<parser::Expr>(&item.u)}) {
586     if (const auto *expr{GetExpr(context_, *x)}) {
587       if (evaluate::IsBOZLiteral(*expr)) {
588         context_.Say(parser::FindSourceLocation(*x), // C7109
589             "Output item must not be a BOZ literal constant"_err_en_US);
590       }
591       const Symbol *last{GetLastSymbol(*expr)};
592       if (last && IsProcedurePointer(*last)) {
593         context_.Say(parser::FindSourceLocation(*x),
594             "Output item must not be a procedure pointer"_err_en_US); // C1233
595       }
596       CheckForBadIoComponent(*expr,
597           flags_.test(Flag::FmtOrNml)
598               ? GenericKind::DefinedIo::WriteFormatted
599               : GenericKind::DefinedIo::WriteUnformatted,
600           parser::FindSourceLocation(item));
601     }
602   }
603 }
604 
Enter(const parser::StatusExpr & spec)605 void IoChecker::Enter(const parser::StatusExpr &spec) {
606   SetSpecifier(IoSpecKind::Status);
607   if (const std::optional<std::string> charConst{
608           GetConstExpr<std::string>(spec)}) {
609     // Status values for Open and Close are different.
610     std::string s{Normalize(*charConst)};
611     if (stmt_ == IoStmtKind::Open) {
612       flags_.set(Flag::KnownStatus);
613       flags_.set(Flag::StatusNew, s == "NEW");
614       flags_.set(Flag::StatusReplace, s == "REPLACE");
615       flags_.set(Flag::StatusScratch, s == "SCRATCH");
616       // CheckStringValue compares for OPEN Status string values.
617       CheckStringValue(
618           IoSpecKind::Status, *charConst, parser::FindSourceLocation(spec));
619       return;
620     }
621     CHECK(stmt_ == IoStmtKind::Close);
622     if (s != "DELETE" && s != "KEEP") {
623       context_.Say(parser::FindSourceLocation(spec),
624           "Invalid STATUS value '%s'"_err_en_US, *charConst);
625     }
626   }
627 }
628 
Enter(const parser::StatVariable & var)629 void IoChecker::Enter(const parser::StatVariable &var) {
630   if (stmt_ == IoStmtKind::None) {
631     // allocate, deallocate, image control
632     CheckForDefinableVariable(var, "STAT");
633     return;
634   }
635   CheckForDefinableVariable(var, "IOSTAT");
636   SetSpecifier(IoSpecKind::Iostat);
637 }
638 
Leave(const parser::BackspaceStmt &)639 void IoChecker::Leave(const parser::BackspaceStmt &) {
640   CheckForPureSubprogram();
641   CheckForRequiredSpecifier(
642       flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
643   Done();
644 }
645 
Leave(const parser::CloseStmt &)646 void IoChecker::Leave(const parser::CloseStmt &) {
647   CheckForPureSubprogram();
648   CheckForRequiredSpecifier(
649       flags_.test(Flag::NumberUnit), "UNIT number"); // C1208
650   Done();
651 }
652 
Leave(const parser::EndfileStmt &)653 void IoChecker::Leave(const parser::EndfileStmt &) {
654   CheckForPureSubprogram();
655   CheckForRequiredSpecifier(
656       flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
657   Done();
658 }
659 
Leave(const parser::FlushStmt &)660 void IoChecker::Leave(const parser::FlushStmt &) {
661   CheckForPureSubprogram();
662   CheckForRequiredSpecifier(
663       flags_.test(Flag::NumberUnit), "UNIT number"); // C1243
664   Done();
665 }
666 
Leave(const parser::InquireStmt & stmt)667 void IoChecker::Leave(const parser::InquireStmt &stmt) {
668   if (std::get_if<std::list<parser::InquireSpec>>(&stmt.u)) {
669     CheckForPureSubprogram();
670     // Inquire by unit or by file (vs. by output list).
671     CheckForRequiredSpecifier(
672         flags_.test(Flag::NumberUnit) || specifierSet_.test(IoSpecKind::File),
673         "UNIT number or FILE"); // C1246
674     CheckForProhibitedSpecifier(IoSpecKind::File, IoSpecKind::Unit); // C1246
675     CheckForRequiredSpecifier(IoSpecKind::Id, IoSpecKind::Pending); // C1248
676   }
677   Done();
678 }
679 
Leave(const parser::OpenStmt &)680 void IoChecker::Leave(const parser::OpenStmt &) {
681   CheckForPureSubprogram();
682   CheckForRequiredSpecifier(specifierSet_.test(IoSpecKind::Unit) ||
683           specifierSet_.test(IoSpecKind::Newunit),
684       "UNIT or NEWUNIT"); // C1204, C1205
685   CheckForProhibitedSpecifier(
686       IoSpecKind::Newunit, IoSpecKind::Unit); // C1204, C1205
687   CheckForRequiredSpecifier(flags_.test(Flag::StatusNew), "STATUS='NEW'",
688       IoSpecKind::File); // 12.5.6.10
689   CheckForRequiredSpecifier(flags_.test(Flag::StatusReplace),
690       "STATUS='REPLACE'", IoSpecKind::File); // 12.5.6.10
691   CheckForProhibitedSpecifier(flags_.test(Flag::StatusScratch),
692       "STATUS='SCRATCH'", IoSpecKind::File); // 12.5.6.10
693   if (flags_.test(Flag::KnownStatus)) {
694     CheckForRequiredSpecifier(IoSpecKind::Newunit,
695         specifierSet_.test(IoSpecKind::File) ||
696             flags_.test(Flag::StatusScratch),
697         "FILE or STATUS='SCRATCH'"); // 12.5.6.12
698   } else {
699     CheckForRequiredSpecifier(IoSpecKind::Newunit,
700         specifierSet_.test(IoSpecKind::File) ||
701             specifierSet_.test(IoSpecKind::Status),
702         "FILE or STATUS"); // 12.5.6.12
703   }
704   if (flags_.test(Flag::KnownAccess)) {
705     CheckForRequiredSpecifier(flags_.test(Flag::AccessDirect),
706         "ACCESS='DIRECT'", IoSpecKind::Recl); // 12.5.6.15
707     CheckForProhibitedSpecifier(flags_.test(Flag::AccessStream),
708         "STATUS='STREAM'", IoSpecKind::Recl); // 12.5.6.15
709   }
710   Done();
711 }
712 
Leave(const parser::PrintStmt &)713 void IoChecker::Leave(const parser::PrintStmt &) {
714   CheckForPureSubprogram();
715   Done();
716 }
717 
CheckForDoVariableInNamelist(const Symbol & namelist,SemanticsContext & context,parser::CharBlock namelistLocation)718 static void CheckForDoVariableInNamelist(const Symbol &namelist,
719     SemanticsContext &context, parser::CharBlock namelistLocation) {
720   const auto &details{namelist.GetUltimate().get<NamelistDetails>()};
721   for (const Symbol &object : details.objects()) {
722     context.CheckIndexVarRedefine(namelistLocation, object);
723   }
724 }
725 
CheckForDoVariableInNamelistSpec(const parser::ReadStmt & readStmt,SemanticsContext & context)726 static void CheckForDoVariableInNamelistSpec(
727     const parser::ReadStmt &readStmt, SemanticsContext &context) {
728   const std::list<parser::IoControlSpec> &controls{readStmt.controls};
729   for (const auto &control : controls) {
730     if (const auto *namelist{std::get_if<parser::Name>(&control.u)}) {
731       if (const Symbol * symbol{namelist->symbol}) {
732         CheckForDoVariableInNamelist(*symbol, context, namelist->source);
733       }
734     }
735   }
736 }
737 
CheckForDoVariable(const parser::ReadStmt & readStmt,SemanticsContext & context)738 static void CheckForDoVariable(
739     const parser::ReadStmt &readStmt, SemanticsContext &context) {
740   CheckForDoVariableInNamelistSpec(readStmt, context);
741   const std::list<parser::InputItem> &items{readStmt.items};
742   for (const auto &item : items) {
743     if (const parser::Variable *
744         variable{std::get_if<parser::Variable>(&item.u)}) {
745       context.CheckIndexVarRedefine(*variable);
746     }
747   }
748 }
749 
Leave(const parser::ReadStmt & readStmt)750 void IoChecker::Leave(const parser::ReadStmt &readStmt) {
751   if (!flags_.test(Flag::InternalUnit)) {
752     CheckForPureSubprogram();
753   }
754   CheckForDoVariable(readStmt, context_);
755   if (!flags_.test(Flag::IoControlList)) {
756     Done();
757     return;
758   }
759   LeaveReadWrite();
760   CheckForProhibitedSpecifier(IoSpecKind::Delim); // C1212
761   CheckForProhibitedSpecifier(IoSpecKind::Sign); // C1212
762   CheckForProhibitedSpecifier(IoSpecKind::Rec, IoSpecKind::End); // C1220
763   CheckForRequiredSpecifier(IoSpecKind::Eor,
764       specifierSet_.test(IoSpecKind::Advance) && !flags_.test(Flag::AdvanceYes),
765       "ADVANCE with value 'NO'"); // C1222 + 12.6.2.1p2
766   CheckForRequiredSpecifier(IoSpecKind::Blank, flags_.test(Flag::FmtOrNml),
767       "FMT or NML"); // C1227
768   CheckForRequiredSpecifier(
769       IoSpecKind::Pad, flags_.test(Flag::FmtOrNml), "FMT or NML"); // C1227
770   Done();
771 }
772 
Leave(const parser::RewindStmt &)773 void IoChecker::Leave(const parser::RewindStmt &) {
774   CheckForRequiredSpecifier(
775       flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
776   CheckForPureSubprogram();
777   Done();
778 }
779 
Leave(const parser::WaitStmt &)780 void IoChecker::Leave(const parser::WaitStmt &) {
781   CheckForRequiredSpecifier(
782       flags_.test(Flag::NumberUnit), "UNIT number"); // C1237
783   CheckForPureSubprogram();
784   Done();
785 }
786 
Leave(const parser::WriteStmt &)787 void IoChecker::Leave(const parser::WriteStmt &) {
788   if (!flags_.test(Flag::InternalUnit)) {
789     CheckForPureSubprogram();
790   }
791   LeaveReadWrite();
792   CheckForProhibitedSpecifier(IoSpecKind::Blank); // C1213
793   CheckForProhibitedSpecifier(IoSpecKind::End); // C1213
794   CheckForProhibitedSpecifier(IoSpecKind::Eor); // C1213
795   CheckForProhibitedSpecifier(IoSpecKind::Pad); // C1213
796   CheckForProhibitedSpecifier(IoSpecKind::Size); // C1213
797   CheckForRequiredSpecifier(
798       IoSpecKind::Sign, flags_.test(Flag::FmtOrNml), "FMT or NML"); // C1227
799   CheckForRequiredSpecifier(IoSpecKind::Delim,
800       flags_.test(Flag::StarFmt) || specifierSet_.test(IoSpecKind::Nml),
801       "FMT=* or NML"); // C1228
802   Done();
803 }
804 
LeaveReadWrite() const805 void IoChecker::LeaveReadWrite() const {
806   CheckForRequiredSpecifier(IoSpecKind::Unit); // C1211
807   CheckForProhibitedSpecifier(IoSpecKind::Nml, IoSpecKind::Rec); // C1216
808   CheckForProhibitedSpecifier(IoSpecKind::Nml, IoSpecKind::Fmt); // C1216
809   CheckForProhibitedSpecifier(
810       IoSpecKind::Nml, flags_.test(Flag::DataList), "a data list"); // C1216
811   CheckForProhibitedSpecifier(flags_.test(Flag::InternalUnit),
812       "UNIT=internal-file", IoSpecKind::Pos); // C1219
813   CheckForProhibitedSpecifier(flags_.test(Flag::InternalUnit),
814       "UNIT=internal-file", IoSpecKind::Rec); // C1219
815   CheckForProhibitedSpecifier(
816       flags_.test(Flag::StarUnit), "UNIT=*", IoSpecKind::Pos); // C1219
817   CheckForProhibitedSpecifier(
818       flags_.test(Flag::StarUnit), "UNIT=*", IoSpecKind::Rec); // C1219
819   CheckForProhibitedSpecifier(
820       IoSpecKind::Rec, flags_.test(Flag::StarFmt), "FMT=*"); // C1220
821   CheckForRequiredSpecifier(IoSpecKind::Advance,
822       flags_.test(Flag::CharFmt) || flags_.test(Flag::LabelFmt) ||
823           flags_.test(Flag::AssignFmt),
824       "an explicit format"); // C1221
825   CheckForProhibitedSpecifier(IoSpecKind::Advance,
826       flags_.test(Flag::InternalUnit), "UNIT=internal-file"); // C1221
827   CheckForRequiredSpecifier(flags_.test(Flag::AsynchronousYes),
828       "ASYNCHRONOUS='YES'", flags_.test(Flag::NumberUnit),
829       "UNIT=number"); // C1224
830   CheckForRequiredSpecifier(IoSpecKind::Id, flags_.test(Flag::AsynchronousYes),
831       "ASYNCHRONOUS='YES'"); // C1225
832   CheckForProhibitedSpecifier(IoSpecKind::Pos, IoSpecKind::Rec); // C1226
833   CheckForRequiredSpecifier(IoSpecKind::Decimal, flags_.test(Flag::FmtOrNml),
834       "FMT or NML"); // C1227
835   CheckForRequiredSpecifier(IoSpecKind::Round, flags_.test(Flag::FmtOrNml),
836       "FMT or NML"); // C1227
837 }
838 
SetSpecifier(IoSpecKind specKind)839 void IoChecker::SetSpecifier(IoSpecKind specKind) {
840   if (stmt_ == IoStmtKind::None) {
841     // FMT may appear on PRINT statements, which don't have any checks.
842     // [IO]MSG and [IO]STAT parse symbols are shared with non-I/O statements.
843     return;
844   }
845   // C1203, C1207, C1210, C1236, C1239, C1242, C1245
846   if (specifierSet_.test(specKind)) {
847     context_.Say("Duplicate %s specifier"_err_en_US,
848         parser::ToUpperCaseLetters(common::EnumToString(specKind)));
849   }
850   specifierSet_.set(specKind);
851 }
852 
CheckStringValue(IoSpecKind specKind,const std::string & value,const parser::CharBlock & source) const853 void IoChecker::CheckStringValue(IoSpecKind specKind, const std::string &value,
854     const parser::CharBlock &source) const {
855   static std::unordered_map<IoSpecKind, const std::set<std::string>> specValues{
856       {IoSpecKind::Access, {"DIRECT", "SEQUENTIAL", "STREAM"}},
857       {IoSpecKind::Action, {"READ", "READWRITE", "WRITE"}},
858       {IoSpecKind::Advance, {"NO", "YES"}},
859       {IoSpecKind::Asynchronous, {"NO", "YES"}},
860       {IoSpecKind::Blank, {"NULL", "ZERO"}},
861       {IoSpecKind::Decimal, {"COMMA", "POINT"}},
862       {IoSpecKind::Delim, {"APOSTROPHE", "NONE", "QUOTE"}},
863       {IoSpecKind::Encoding, {"DEFAULT", "UTF-8"}},
864       {IoSpecKind::Form, {"FORMATTED", "UNFORMATTED"}},
865       {IoSpecKind::Pad, {"NO", "YES"}},
866       {IoSpecKind::Position, {"APPEND", "ASIS", "REWIND"}},
867       {IoSpecKind::Round,
868           {"COMPATIBLE", "DOWN", "NEAREST", "PROCESSOR_DEFINED", "UP", "ZERO"}},
869       {IoSpecKind::Sign, {"PLUS", "PROCESSOR_DEFINED", "SUPPRESS"}},
870       {IoSpecKind::Status,
871           // Open values; Close values are {"DELETE", "KEEP"}.
872           {"NEW", "OLD", "REPLACE", "SCRATCH", "UNKNOWN"}},
873       {IoSpecKind::Carriagecontrol, {"LIST", "FORTRAN", "NONE"}},
874       {IoSpecKind::Convert, {"BIG_ENDIAN", "LITTLE_ENDIAN", "NATIVE"}},
875       {IoSpecKind::Dispose, {"DELETE", "KEEP"}},
876   };
877   auto upper{Normalize(value)};
878   if (specValues.at(specKind).count(upper) == 0) {
879     if (specKind == IoSpecKind::Access && upper == "APPEND") {
880       if (context_.languageFeatures().ShouldWarn(
881               common::LanguageFeature::OpenAccessAppend)) {
882         context_.Say(source,
883             "ACCESS='%s' interpreted as POSITION='%s'"_port_en_US, value,
884             upper);
885       }
886     } else {
887       context_.Say(source, "Invalid %s value '%s'"_err_en_US,
888           parser::ToUpperCaseLetters(common::EnumToString(specKind)), value);
889     }
890   }
891 }
892 
893 // CheckForRequiredSpecifier and CheckForProhibitedSpecifier functions
894 // need conditions to check, and string arguments to insert into a message.
895 // An IoSpecKind provides both an absence/presence condition and a string
896 // argument (its name).  A (condition, string) pair provides an arbitrary
897 // condition and an arbitrary string.
898 
CheckForRequiredSpecifier(IoSpecKind specKind) const899 void IoChecker::CheckForRequiredSpecifier(IoSpecKind specKind) const {
900   if (!specifierSet_.test(specKind)) {
901     context_.Say("%s statement must have a %s specifier"_err_en_US,
902         parser::ToUpperCaseLetters(common::EnumToString(stmt_)),
903         parser::ToUpperCaseLetters(common::EnumToString(specKind)));
904   }
905 }
906 
CheckForRequiredSpecifier(bool condition,const std::string & s) const907 void IoChecker::CheckForRequiredSpecifier(
908     bool condition, const std::string &s) const {
909   if (!condition) {
910     context_.Say("%s statement must have a %s specifier"_err_en_US,
911         parser::ToUpperCaseLetters(common::EnumToString(stmt_)), s);
912   }
913 }
914 
CheckForRequiredSpecifier(IoSpecKind specKind1,IoSpecKind specKind2) const915 void IoChecker::CheckForRequiredSpecifier(
916     IoSpecKind specKind1, IoSpecKind specKind2) const {
917   if (specifierSet_.test(specKind1) && !specifierSet_.test(specKind2)) {
918     context_.Say("If %s appears, %s must also appear"_err_en_US,
919         parser::ToUpperCaseLetters(common::EnumToString(specKind1)),
920         parser::ToUpperCaseLetters(common::EnumToString(specKind2)));
921   }
922 }
923 
CheckForRequiredSpecifier(IoSpecKind specKind,bool condition,const std::string & s) const924 void IoChecker::CheckForRequiredSpecifier(
925     IoSpecKind specKind, bool condition, const std::string &s) const {
926   if (specifierSet_.test(specKind) && !condition) {
927     context_.Say("If %s appears, %s must also appear"_err_en_US,
928         parser::ToUpperCaseLetters(common::EnumToString(specKind)), s);
929   }
930 }
931 
CheckForRequiredSpecifier(bool condition,const std::string & s,IoSpecKind specKind) const932 void IoChecker::CheckForRequiredSpecifier(
933     bool condition, const std::string &s, IoSpecKind specKind) const {
934   if (condition && !specifierSet_.test(specKind)) {
935     context_.Say("If %s appears, %s must also appear"_err_en_US, s,
936         parser::ToUpperCaseLetters(common::EnumToString(specKind)));
937   }
938 }
939 
CheckForRequiredSpecifier(bool condition1,const std::string & s1,bool condition2,const std::string & s2) const940 void IoChecker::CheckForRequiredSpecifier(bool condition1,
941     const std::string &s1, bool condition2, const std::string &s2) const {
942   if (condition1 && !condition2) {
943     context_.Say("If %s appears, %s must also appear"_err_en_US, s1, s2);
944   }
945 }
946 
CheckForProhibitedSpecifier(IoSpecKind specKind) const947 void IoChecker::CheckForProhibitedSpecifier(IoSpecKind specKind) const {
948   if (specifierSet_.test(specKind)) {
949     context_.Say("%s statement must not have a %s specifier"_err_en_US,
950         parser::ToUpperCaseLetters(common::EnumToString(stmt_)),
951         parser::ToUpperCaseLetters(common::EnumToString(specKind)));
952   }
953 }
954 
CheckForProhibitedSpecifier(IoSpecKind specKind1,IoSpecKind specKind2) const955 void IoChecker::CheckForProhibitedSpecifier(
956     IoSpecKind specKind1, IoSpecKind specKind2) const {
957   if (specifierSet_.test(specKind1) && specifierSet_.test(specKind2)) {
958     context_.Say("If %s appears, %s must not appear"_err_en_US,
959         parser::ToUpperCaseLetters(common::EnumToString(specKind1)),
960         parser::ToUpperCaseLetters(common::EnumToString(specKind2)));
961   }
962 }
963 
CheckForProhibitedSpecifier(IoSpecKind specKind,bool condition,const std::string & s) const964 void IoChecker::CheckForProhibitedSpecifier(
965     IoSpecKind specKind, bool condition, const std::string &s) const {
966   if (specifierSet_.test(specKind) && condition) {
967     context_.Say("If %s appears, %s must not appear"_err_en_US,
968         parser::ToUpperCaseLetters(common::EnumToString(specKind)), s);
969   }
970 }
971 
CheckForProhibitedSpecifier(bool condition,const std::string & s,IoSpecKind specKind) const972 void IoChecker::CheckForProhibitedSpecifier(
973     bool condition, const std::string &s, IoSpecKind specKind) const {
974   if (condition && specifierSet_.test(specKind)) {
975     context_.Say("If %s appears, %s must not appear"_err_en_US, s,
976         parser::ToUpperCaseLetters(common::EnumToString(specKind)));
977   }
978 }
979 
980 template <typename A>
CheckForDefinableVariable(const A & variable,const std::string & s) const981 void IoChecker::CheckForDefinableVariable(
982     const A &variable, const std::string &s) const {
983   if (const auto *var{parser::Unwrap<parser::Variable>(variable)}) {
984     if (auto expr{AnalyzeExpr(context_, *var)}) {
985       auto at{var->GetSource()};
986       if (auto whyNot{WhyNotModifiable(at, *expr, context_.FindScope(at),
987               true /*vectorSubscriptIsOk*/)}) {
988         const Symbol *base{GetFirstSymbol(*expr)};
989         context_
990             .Say(at, "%s variable '%s' must be definable"_err_en_US, s,
991                 (base ? base->name() : at).ToString())
992             .Attach(std::move(*whyNot));
993       }
994     }
995   }
996 }
997 
CheckForPureSubprogram() const998 void IoChecker::CheckForPureSubprogram() const { // C1597
999   CHECK(context_.location());
1000   if (const Scope *
1001       scope{context_.globalScope().FindScope(*context_.location())}) {
1002     if (FindPureProcedureContaining(*scope)) {
1003       context_.Say(
1004           "External I/O is not allowed in a pure subprogram"_err_en_US);
1005     }
1006   }
1007 }
1008 
1009 // Fortran 2018, 12.6.3 paragraph 7
CheckForBadIoComponent(const SomeExpr & expr,GenericKind::DefinedIo which,parser::CharBlock where) const1010 void IoChecker::CheckForBadIoComponent(const SomeExpr &expr,
1011     GenericKind::DefinedIo which, parser::CharBlock where) const {
1012   if (auto type{expr.GetType()}) {
1013     if (type->category() == TypeCategory::Derived &&
1014         !type->IsUnlimitedPolymorphic()) {
1015       if (const Symbol *
1016           bad{FindUnsafeIoDirectComponent(
1017               which, type->GetDerivedTypeSpec(), &context_.FindScope(where))}) {
1018         context_.SayWithDecl(*bad, where,
1019             "Derived type in I/O cannot have an allocatable or pointer direct component unless using defined I/O"_err_en_US);
1020       }
1021     }
1022   }
1023 }
1024 
1025 } // namespace Fortran::semantics
1026