flang/lib/Semantics/check-io.cpp

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