diff --git a/flang/include/flang/Semantics/expression.h b/flang/include/flang/Semantics/expression.h --- a/flang/include/flang/Semantics/expression.h +++ b/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 @@ // its INTEGER kind type parameter. std::optional IsImpliedDo(parser::CharBlock) const; + // Allows a whole assumed-size array to appear for the lifetime of + // the returned value. + common::Restorer AllowWholeAssumedSizeArray() { + return common::ScopedSet(isWholeAssumedSizeArrayOk_, true); + } + Expr AnalyzeKindSelector(common::TypeCategory category, const std::optional &); @@ -372,6 +379,7 @@ FoldingContext &foldingContext_{context_.foldingContext()}; std::map impliedDos_; // values are INTEGER kinds bool fatalErrors_{false}; + bool isWholeAssumedSizeArrayOk_{false}; friend class ArgumentAnalyzer; }; diff --git a/flang/lib/Semantics/assignment.cpp b/flang/lib/Semantics/assignment.cpp --- a/flang/lib/Semantics/assignment.cpp +++ b/flang/lib/Semantics/assignment.cpp @@ -66,11 +66,6 @@ const SomeExpr &rhs{assignment->rhs}; auto lhsLoc{std::get(stmt.t).GetSource()}; auto rhsLoc{std::get(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)}) { diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp --- a/flang/lib/Semantics/check-io.cpp +++ b/flang/lib/Semantics/check-io.cpp @@ -298,14 +298,6 @@ 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) { diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -151,6 +151,7 @@ std::vector, parser::MessageFixedText &&); MaybeExpr TryBoundOp(const Symbol &, int passIndex); std::optional 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 @@ 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 @@ } 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::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 @@ } } } + std::optional ArgumentAnalyzer::AnalyzeExpr( const parser::Expr &expr) { source_.ExtendToCover(expr.source); @@ -2990,26 +3002,33 @@ 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))}; + } + 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(expr)}) { + if (name->symbol && semantics::IsAssumedSizeArray(*name->symbol)) { + auto restorer{context_.AllowWholeAssumedSizeArray()}; + return context_.Analyze(expr); } - return ActualArgument{context_.Fold(std::move(*argExpr))}; - } else { - return std::nullopt; } + return context_.Analyze(expr); } bool ArgumentAnalyzer::AreConformable() const { diff --git a/flang/test/Semantics/assign04.f90 b/flang/test/Semantics/assign04.f90 --- a/flang/test/Semantics/assign04.f90 +++ b/flang/test/Semantics/assign04.f90 @@ -94,7 +94,7 @@ 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 @@ 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 diff --git a/flang/test/Semantics/io03.f90 b/flang/test/Semantics/io03.f90 --- a/flang/test/Semantics/io03.f90 +++ b/flang/test/Semantics/io03.f90 @@ -178,6 +178,6 @@ !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