[flang] Semantic checks for bad usage of whole assumed-size arrays

The semantics pass currently checks for several constraints
that apply to the use of whole assumed-size arrays in various
contexts, but C1002 wasn't really implemented.  This patch
implements C1002 by disallowing the use of whole assumed-size
arrays in expressions and variables unless specifically
allowed by the context.  This centralizes the error reporting,
which has been improved with a link to the array's declaration.

Differential revision: https://reviews.llvm.org/D88691

flang/include/flang/Semantics/expression.h

@@ -12,6 +12,7 @@
 #include "semantics.h"
 #include "flang/Common/Fortran.h"
 #include "flang/Common/indirection.h"
+#include "flang/Common/restorer.h"
 #include "flang/Evaluate/characteristics.h"
 #include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/expression.h"
@@ -139,6 +140,12 @@ public:
   // its INTEGER kind type parameter.
   std::optional<int> IsImpliedDo(parser::CharBlock) const;
 
+  // Allows a whole assumed-size array to appear for the lifetime of
+  // the returned value.
+  common::Restorer<bool> AllowWholeAssumedSizeArray() {
+    return common::ScopedSet(isWholeAssumedSizeArrayOk_, true);
+  }
+
   Expr<SubscriptInteger> AnalyzeKindSelector(common::TypeCategory category,
       const std::optional<parser::KindSelector> &);
 
@@ -372,6 +379,7 @@ private:
   FoldingContext &foldingContext_{context_.foldingContext()};
   std::map<parser::CharBlock, int> impliedDos_; // values are INTEGER kinds
   bool fatalErrors_{false};
+  bool isWholeAssumedSizeArrayOk_{false};
   friend class ArgumentAnalyzer;
 };
 

flang/lib/Semantics/assignment.cpp

@@ -66,11 +66,6 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
     const SomeExpr &rhs{assignment->rhs};
     auto lhsLoc{std::get<parser::Variable>(stmt.t).GetSource()};
     auto rhsLoc{std::get<parser::Expr>(stmt.t).source};
-    auto shape{evaluate::GetShape(foldingContext(), lhs)};
-    if (shape && !shape->empty() && !shape->back().has_value()) { // C1014
-      Say(lhsLoc,
-          "Left-hand side of assignment may not be a whole assumed-size array"_err_en_US);
-    }
     if (CheckForPureContext(lhs, rhs, rhsLoc, false)) {
       const Scope &scope{context_.FindScope(lhsLoc)};
       if (auto whyNot{WhyNotModifiable(lhsLoc, lhs, scope, true)}) {

flang/lib/Semantics/check-io.cpp

@@ -298,14 +298,6 @@ void IoChecker::Enter(const parser::InputItem &spec) {
     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
-  }
 }
 
 void IoChecker::Enter(const parser::InquireSpec &spec) {

flang/lib/Semantics/expression.cpp

@@ -151,6 +151,7 @@ private:
       std::vector<const char *>, parser::MessageFixedText &&);
   MaybeExpr TryBoundOp(const Symbol &, int passIndex);
   std::optional<ActualArgument> AnalyzeExpr(const parser::Expr &);
+  MaybeExpr AnalyzeExprOrWholeAssumedSizeArray(const parser::Expr &);
   bool AreConformable() const;
   const Symbol *FindBoundOp(parser::CharBlock, int passIndex);
   void AddAssignmentConversion(
@@ -673,6 +674,14 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
           n.symbol->attrs().reset(semantics::Attr::VOLATILE);
         }
       }
+      if (!isWholeAssumedSizeArrayOk_ &&
+          semantics::IsAssumedSizeArray(*n.symbol)) { // C1002, C1014, C1231
+        AttachDeclaration(
+            SayAt(n,
+                "Whole assumed-size array '%s' may not appear here without subscripts"_err_en_US,
+                n.source),
+            *n.symbol);
+      }
       return Designate(DataRef{*n.symbol});
     }
   }
@@ -885,7 +894,12 @@ std::vector<Subscript> ExpressionAnalyzer::AnalyzeSectionSubscripts(
 }
 
 MaybeExpr ExpressionAnalyzer::Analyze(const parser::ArrayElement &ae) {
-  if (MaybeExpr baseExpr{Analyze(ae.base)}) {
+  MaybeExpr baseExpr;
+  {
+    auto restorer{AllowWholeAssumedSizeArray()};
+    baseExpr = Analyze(ae.base);
+  }
+  if (baseExpr) {
     if (ae.subscripts.empty()) {
       // will be converted to function call later or error reported
       return std::nullopt;
@@ -2713,9 +2727,6 @@ void ArgumentAnalyzer::Analyze(const parser::Variable &x) {
 
 void ArgumentAnalyzer::Analyze(
     const parser::ActualArgSpec &arg, bool isSubroutine) {
-  // TODO: C1002: Allow a whole assumed-size array to appear if the dummy
-  // argument would accept it.  Handle by special-casing the context
-  // ActualArg -> Variable -> Designator.
   // TODO: Actual arguments that are procedures and procedure pointers need to
   // be detected and represented (they're not expressions).
   // TODO: C1534: Don't allow a "restricted" specific intrinsic to be passed.
@@ -2983,6 +2994,7 @@ void ArgumentAnalyzer::Dump(llvm::raw_ostream &os) {
     }
   }
 }
+
 std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
     const parser::Expr &expr) {
   source_.ExtendToCover(expr.source);
@@ -2990,26 +3002,33 @@ std::optional<ActualArgument> ArgumentAnalyzer::AnalyzeExpr(
     expr.typedExpr.Reset(new GenericExprWrapper{}, GenericExprWrapper::Deleter);
     if (isProcedureCall_) {
       return ActualArgument{ActualArgument::AssumedType{*assumedTypeDummy}};
-    } else {
-      context_.SayAt(expr.source,
-          "TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
-      return std::nullopt;
     }
-  } else if (MaybeExpr argExpr{context_.Analyze(expr)}) {
-    if (!isProcedureCall_ && IsProcedure(*argExpr)) {
-      if (IsFunction(*argExpr)) {
-        context_.SayAt(
-            expr.source, "Function call must have argument list"_err_en_US);
-      } else {
-        context_.SayAt(
-            expr.source, "Subroutine name is not allowed here"_err_en_US);
-      }
-      return std::nullopt;
+    context_.SayAt(expr.source,
+        "TYPE(*) dummy argument may only be used as an actual argument"_err_en_US);
+  } else if (MaybeExpr argExpr{AnalyzeExprOrWholeAssumedSizeArray(expr)}) {
+    if (isProcedureCall_ || !IsProcedure(*argExpr)) {
+      return ActualArgument{context_.Fold(std::move(*argExpr))};
     }
-    return ActualArgument{context_.Fold(std::move(*argExpr))};
-  } else {
-    return std::nullopt;
+    context_.SayAt(expr.source,
+        IsFunction(*argExpr) ? "Function call must have argument list"_err_en_US
+                             : "Subroutine name is not allowed here"_err_en_US);
   }
+  return std::nullopt;
+}
+
+MaybeExpr ArgumentAnalyzer::AnalyzeExprOrWholeAssumedSizeArray(
+    const parser::Expr &expr) {
+  // If an expression's parse tree is a whole assumed-size array:
+  //   Expr -> Designator -> DataRef -> Name
+  // treat it as a special case for argument passing and bypass
+  // the C1002/C1014 constraint checking in expression semantics.
+  if (const auto *name{parser::Unwrap<parser::Name>(expr)}) {
+    if (name->symbol && semantics::IsAssumedSizeArray(*name->symbol)) {
+      auto restorer{context_.AllowWholeAssumedSizeArray()};
+      return context_.Analyze(expr);
+    }
+  }
+  return context_.Analyze(expr);
 }
 
 bool ArgumentAnalyzer::AreConformable() const {

flang/test/Semantics/assign04.f90

@@ -94,7 +94,7 @@ subroutine s6(x)
   x(:3) = [1, 2, 3]
   !ERROR: Assumed-size array 'x' must have explicit final subscript upper bound value
   x(:) = [1, 2, 3]
-  !ERROR: Left-hand side of assignment may not be a whole assumed-size array
+  !ERROR: Whole assumed-size array 'x' may not appear here without subscripts
   x = [1, 2, 3]
 end
 
@@ -106,7 +106,7 @@ contains
   subroutine s7(x)
     type(t) :: x(*)
     x(:3)%i = [1, 2, 3]
-    !ERROR: Left-hand side of assignment may not be a whole assumed-size array
+    !ERROR: Whole assumed-size array 'x' may not appear here without subscripts
     x%i = [1, 2, 3]
   end
 end

flang/test/Semantics/io03.f90

@@ -178,6 +178,6 @@ subroutine s(aa, n)
   !ERROR: Input variable 'n' must be definable
   read(*, *) n
 
-  !ERROR: Whole assumed size array 'aa' may not be an input item
+  !ERROR: Whole assumed-size array 'aa' may not appear here without subscripts
   read(*, *) aa
 end