[flang] Check that various variables referenced in I/O statements may be defined

A number of I/O syntax rules involve variables that will be written to,
and must therefore be definable.  This includes internal file variables,
IOSTAT= and IOMSG= specifiers, most INQUIRE statement specifiers, a few
other specifiers, and input variables.  This patch checks for
these violations, and implements several additional I/O TODO constraint
checks.

Differential Revision: https://reviews.llvm.org/D86557

Author: klausler

flang/lib/Semantics/check-io.cpp

@@ -155,7 +155,8 @@ void IoChecker::Enter(const parser::ConnectSpec::CharExpr &spec) {
   }
 }
 
-void IoChecker::Enter(const parser::ConnectSpec::Newunit &) {
+void IoChecker::Enter(const parser::ConnectSpec::Newunit &var) {
+  CheckForDefinableVariable(var, "NEWUNIT");
   SetSpecifier(IoSpecKind::Newunit);
 }
 
@@ -266,10 +267,11 @@ void IoChecker::Enter(const parser::IdExpr &) { SetSpecifier(IoSpecKind::Id); }
 
 void IoChecker::Enter(const parser::IdVariable &spec) {
   SetSpecifier(IoSpecKind::Id);
-  auto expr{GetExpr(spec)};
+  const auto *expr{GetExpr(spec)};
   if (!expr || !expr->GetType()) {
     return;
   }
+  CheckForDefinableVariable(spec, "ID");
   int kind{expr->GetType()->kind()};
   int defaultKind{context_.GetDefaultKind(TypeCategory::Integer)};
   if (kind < defaultKind) {
@@ -281,21 +283,18 @@ void IoChecker::Enter(const parser::IdVariable &spec) {
 
 void IoChecker::Enter(const parser::InputItem &spec) {
   flags_.set(Flag::DataList);
-  if (const parser::Variable * var{std::get_if<parser::Variable>(&spec.u)}) {
-    const parser::Name &name{GetLastName(*var)};
-    if (name.symbol) {
-      if (auto *details{name.symbol->detailsIf<ObjectEntityDetails>()}) {
-        // TODO: Determine if this check is needed at all, and if so, replace
-        // the false subcondition with a check for a whole array.  Otherwise,
-        // the check incorrectly flags array element and section references.
-        if (details->IsAssumedSize() && false) {
-          // This check may be superseded by C928 or C1002.
-          context_.Say(name.source,
-              "'%s' must not be a whole assumed size array"_err_en_US,
-              name.source); // C1231
-        }
-      }
-    }
+  const parser::Variable *var{std::get_if<parser::Variable>(&spec.u)};
+  if (!var) {
+    return;
+  }
+  CheckForDefinableVariable(*var, "Input");
+  const auto &name{GetLastName(*var)};
+  const auto *expr{GetExpr(*var)};
+  if (name.symbol && IsAssumedSizeArray(*name.symbol) && expr &&
+      !evaluate::IsArrayElement(*GetExpr(*var))) {
+    context_.Say(name.source,
+        "Whole assumed size array '%s' may not be an input item"_err_en_US,
+        name.source); // C1231
   }
 }
 
@@ -386,6 +385,8 @@ void IoChecker::Enter(const parser::InquireSpec::CharVar &spec) {
     specKind = IoSpecKind::Dispose;
     break;
   }
+  CheckForDefinableVariable(std::get<parser::ScalarDefaultCharVariable>(spec.t),
+      parser::ToUpperCaseLetters(common::EnumToString(specKind)));
   SetSpecifier(specKind);
 }
 
@@ -412,6 +413,8 @@ void IoChecker::Enter(const parser::InquireSpec::IntVar &spec) {
     specKind = IoSpecKind::Size;
     break;
   }
+  CheckForDefinableVariable(std::get<parser::ScalarIntVariable>(spec.t),
+      parser::ToUpperCaseLetters(common::EnumToString(specKind)));
   SetSpecifier(specKind);
 }
 
@@ -500,17 +503,23 @@ void IoChecker::Enter(const parser::IoControlSpec::Rec &) {
   SetSpecifier(IoSpecKind::Rec);
 }
 
-void IoChecker::Enter(const parser::IoControlSpec::Size &) {
+void IoChecker::Enter(const parser::IoControlSpec::Size &var) {
+  CheckForDefinableVariable(var, "SIZE");
   SetSpecifier(IoSpecKind::Size);
 }
 
 void IoChecker::Enter(const parser::IoUnit &spec) {
   if (const parser::Variable * var{std::get_if<parser::Variable>(&spec.u)}) {
-    // TODO: C1201 - internal file variable must not be an array section ...
-    if (auto expr{GetExpr(*var)}) {
-      if (!ExprTypeKindIsDefault(*expr, context_)) {
+    if (stmt_ == IoStmtKind::Write) {
+      CheckForDefinableVariable(*var, "Internal file");
+    }
+    if (const auto *expr{GetExpr(*var)}) {
+      if (HasVectorSubscript(*expr)) {
+        context_.Say(parser::FindSourceLocation(*var), // C1201
+            "Internal file must not have a vector subscript"_err_en_US);
+      } else if (!ExprTypeKindIsDefault(*expr, context_)) {
         // This may be too restrictive; other kinds may be valid.
-        context_.Say( // C1202
+        context_.Say(parser::FindSourceLocation(*var), // C1202
             "Invalid character kind for an internal file variable"_err_en_US);
       }
     }
@@ -522,13 +531,26 @@ void IoChecker::Enter(const parser::IoUnit &spec) {
   }
 }
 
-void IoChecker::Enter(const parser::MsgVariable &) {
+void IoChecker::Enter(const parser::MsgVariable &var) {
+  if (stmt_ == IoStmtKind::None) {
+    // allocate, deallocate, image control
+    CheckForDefinableVariable(var, "ERRMSG");
+    return;
+  }
+  CheckForDefinableVariable(var, "IOMSG");
   SetSpecifier(IoSpecKind::Iomsg);
 }
 
-void IoChecker::Enter(const parser::OutputItem &) {
+void IoChecker::Enter(const parser::OutputItem &item) {
   flags_.set(Flag::DataList);
-  // TODO: C1233 - output item must not be a procedure pointer
+  if (const auto *x{std::get_if<parser::Expr>(&item.u)}) {
+    if (const auto *expr{GetExpr(*x)}) {
+      if (IsProcedurePointer(*expr)) {
+        context_.Say(parser::FindSourceLocation(*x),
+            "Output item must not be a procedure pointer"_err_en_US); // C1233
+      }
+    }
+  }
 }
 
 void IoChecker::Enter(const parser::StatusExpr &spec) {
@@ -555,12 +577,14 @@ void IoChecker::Enter(const parser::StatusExpr &spec) {
   }
 }
 
-void IoChecker::Enter(const parser::StatVariable &) {
+void IoChecker::Enter(const parser::StatVariable &var) {
   if (stmt_ == IoStmtKind::None) {
-    // ALLOCATE & DEALLOCATE
-  } else {
-    SetSpecifier(IoSpecKind::Iostat);
+    // allocate, deallocate, image control
+    CheckForDefinableVariable(var, "STAT");
+    return;
   }
+  CheckForDefinableVariable(var, "IOSTAT");
+  SetSpecifier(IoSpecKind::Iostat);
 }
 
 void IoChecker::Leave(const parser::BackspaceStmt &) {
@@ -808,7 +832,7 @@ void IoChecker::CheckStringValue(IoSpecKind specKind, const std::string &value,
 
 // CheckForRequiredSpecifier and CheckForProhibitedSpecifier functions
 // need conditions to check, and string arguments to insert into a message.
-// A IoSpecKind provides both an absence/presence condition and a string
+// An IoSpecKind provides both an absence/presence condition and a string
 // argument (its name).  A (condition, string) pair provides an arbitrary
 // condition and an arbitrary string.
 
@@ -893,6 +917,17 @@ void IoChecker::CheckForProhibitedSpecifier(
   }
 }
 
+template <typename A>
+void IoChecker::CheckForDefinableVariable(
+    const A &var, const std::string &s) const {
+  const Symbol *sym{
+      GetFirstName(*parser::Unwrap<parser::Variable>(var)).symbol};
+  if (WhyNotModifiable(*sym, context_.FindScope(*context_.location()))) {
+    context_.Say(parser::FindSourceLocation(var),
+        "%s variable '%s' must be definable"_err_en_US, s, sym->name());
+  }
+}
+
 void IoChecker::CheckForPureSubprogram() const { // C1597
   CHECK(context_.location());
   if (FindPureProcedureContaining(context_.FindScope(*context_.location()))) {

flang/lib/Semantics/check-io.h

@@ -122,6 +122,11 @@ class IoChecker : public virtual BaseChecker {
   void CheckForProhibitedSpecifier(IoSpecKind, bool, const std::string &) const;
   void CheckForProhibitedSpecifier(bool, const std::string &, IoSpecKind) const;
 
+  template <typename A>
+  void CheckForDefinableVariable(const A &var, const std::string &s) const;
+
+  void CheckForPureSubprogram() const;
+
   void Init(IoStmtKind s) {
     stmt_ = s;
     specifierSet_.reset();
@@ -130,8 +135,6 @@ class IoChecker : public virtual BaseChecker {
 
   void Done() { stmt_ = IoStmtKind::None; }
 
-  void CheckForPureSubprogram() const;
-
   SemanticsContext &context_;
   IoStmtKind stmt_{IoStmtKind::None};
   common::EnumSet<IoSpecKind, common::IoSpecKind_enumSize> specifierSet_;

flang/test/Semantics/deallocate05.f90

@@ -21,6 +21,7 @@ Program deallocatetest
 
 Real :: r
 Integer :: s
+Integer, Parameter :: const_s = 13
 Integer :: e
 Integer :: pi
 Character(256) :: ee
@@ -56,6 +57,8 @@ Program deallocatetest
 
 !ERROR: STAT may not be duplicated in a DEALLOCATE statement
 Deallocate(x, stat=s, stat=s)
+!ERROR: STAT variable 'const_s' must be definable
+Deallocate(x, stat=const_s)
 !ERROR: ERRMSG may not be duplicated in a DEALLOCATE statement
 Deallocate(x, errmsg=ee, errmsg=ee)
 !ERROR: STAT may not be duplicated in a DEALLOCATE statement

flang/test/Semantics/io01.f90

@@ -21,6 +21,7 @@
   integer :: unit10 = 10
   integer :: unit11 = 11
   integer :: n = 40
+  integer, parameter :: const_new_unit = 66
 
   integer(kind=1) :: stat1
   integer(kind=2) :: stat2
@@ -73,6 +74,9 @@
   !ERROR: If NEWUNIT appears, FILE or STATUS must also appear
   open(newunit=n, newunit=nn, iostat=stat4)
 
+  !ERROR: NEWUNIT variable 'const_new_unit' must be definable
+  open(newunit=const_new_unit, status=cc)
+
   !ERROR: Duplicate UNIT specifier
   open(unit=100, unit=100)
 

flang/test/Semantics/io02.f90

@@ -1,6 +1,7 @@
 ! RUN: %S/test_errors.sh %s %t %f18
   integer :: unit10 = 10
   integer :: unit11 = 11
+  integer, parameter :: const_stat = 6666
 
   integer(kind=1) :: stat1
   integer(kind=8) :: stat8
@@ -28,5 +29,8 @@
   !ERROR: Invalid STATUS value 'old'
   close(status='old', unit=17)
 
+  !ERROR: IOSTAT variable 'const_stat' must be definable
+  close(14, iostat=const_stat)
+
 9 continue
 end

flang/test/Semantics/io03.f90

@@ -2,13 +2,18 @@
   character(kind=1,len=50) internal_file
   character(kind=2,len=50) internal_file2
   character(kind=4,len=50) internal_file4
+  character(kind=1,len=50) internal_fileA(20)
   character(kind=1,len=111) msg
   character(20) advance
+  character(20) :: cvar;
+  character, parameter :: const_internal_file = "(I6)"
+  character, parameter :: const_cvar = "Ceci n'est pas une pipe."
   integer*1 stat1
   integer*2 stat2, id2
   integer*8 stat8
   integer :: iunit = 10
-  integer, parameter :: junit = 11
+  integer, parameter :: junit = 11, const_size = 13, const_int = 15
+  integer :: vv(10) = 7
 
   namelist /mmm/ mm1, mm2
   namelist /nnn/ nn1, nn2
@@ -29,11 +34,14 @@
   read(fmt='(I4)', unit=*) jj
   read(iunit, *) jj
   read(junit, *) jj
-  read(10, *) jj
+  read(10, *) jj, cvar, cvar(7:17)
   read(internal_file, *) jj
+  read(internal_fileA(3), *) jj
+  read(internal_fileA(4:9), *) jj
   read(10, nnn)
   read(internal_file, nnn)
   read(internal_file, nml=nnn)
+  read(const_internal_file, *)
   read(fmt=*, unit=internal_file)
   read(nml=nnn, unit=internal_file)
   read(iunit, nnn)
@@ -53,6 +61,21 @@
   !ERROR: Invalid character kind for an internal file variable
   read(internal_file4, *) jj
 
+  !ERROR: Internal file must not have a vector subscript
+  read(internal_fileA(vv), *) jj
+
+  !ERROR: Input variable 'const_int' must be definable
+  read(11, *) const_int
+
+  !ERROR: SIZE variable 'const_size' must be definable
+  read(11, pos=ipos, size=const_size, end=9)
+
+  !ERROR: Input variable 'const_cvar' must be definable
+  read(11, *) const_cvar
+
+  !ERROR: Input variable 'const_cvar' must be definable
+  read(11, *) const_cvar(3:13)
+
   !ERROR: Duplicate IOSTAT specifier
   read(11, pos=ipos, iostat=stat1, iostat=stat2)
 
@@ -136,3 +159,25 @@
 
 9 continue
 end
+
+subroutine s(aa, n)
+  integer :: aa(5,*)
+  integer, intent(in) :: n
+  integer :: bb(10), vv(10)
+  type tt
+    real :: x, y, z
+  end type tt
+  type(tt) :: qq(20)
+
+  vv = 1
+
+  read(*, *) aa(n,1)
+  read(*, *) aa(n:n+2,2)
+  read(*, *) qq(2:5)%y
+
+  !ERROR: Input variable 'n' must be definable
+  read(*, *) n
+
+  !ERROR: Whole assumed size array 'aa' may not be an input item
+  read(*, *) aa
+end

flang/test/Semantics/io04.f90

@@ -2,13 +2,16 @@
   character(kind=1,len=50) internal_file
   character(kind=1,len=100) msg
   character(20) sign
+  character, parameter :: const_internal_file = "(I6)"
   integer*1 stat1, id1
   integer*2 stat2
   integer*4 stat4
   integer*8 stat8
   integer :: iunit = 10
   integer, parameter :: junit = 11
   integer, pointer :: a(:)
+  integer, parameter :: const_id = 66666
+  procedure(), pointer :: procptr
 
   namelist /nnn/ nn1, nn2
 
@@ -66,6 +69,9 @@
   !ERROR: If NML appears, a data list must not appear
   write(10, nnn, rec=40, fmt=1) 'Ok'
 
+  !ERROR: Internal file variable 'const_internal_file' must be definable
+  write(const_internal_file, fmt=*)
+
   !ERROR: If UNIT=* appears, POS must not appear
   write(*, pos=n, nml=nnn)
 
@@ -118,8 +124,14 @@
   !ERROR: ID kind (1) is smaller than default INTEGER kind (4)
   write(id=id1, unit=10, asynchronous='Yes') 'Ok'
 
+  !ERROR: ID variable 'const_id' must be definable
+  write(10, *, asynchronous='yes', id=const_id, iostat=stat2) 'Ok'
+
   write(*, '(X)')
 
+  !ERROR: Output item must not be a procedure pointer
+  print*, n1, procptr, n2
+
 1 format (A)
 9 continue
 end