diff --git a/flang/include/flang/Evaluate/expression.h b/flang/include/flang/Evaluate/expression.h index 1afe8ae74c415..2df16d9a174a6 100644 --- a/flang/include/flang/Evaluate/expression.h +++ b/flang/include/flang/Evaluate/expression.h @@ -586,12 +586,15 @@ class Expr> using DescriptorInquiries = std::conditional_t, std::tuple<>>; + using RankOneBoundElements = + std::conditional_t, std::tuple<>>; using Others = std::tuple, ArrayConstructor, Designator, FunctionRef>; public: common::TupleToVariant> + TypeParamInquiries, DescriptorInquiries, RankOneBoundElements, Others>> u; }; diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h index e5c2d6e8cb63d..e0148ef97a58d 100644 --- a/flang/include/flang/Evaluate/shape.h +++ b/flang/include/flang/Evaluate/shape.h @@ -165,6 +165,7 @@ class GetShapeHelper Result operator()(const ImpliedDoIndex &) const { return ScalarShape(); } Result operator()(const DescriptorInquiry &) const { return ScalarShape(); } + Result operator()(const RankOneBoundElement &) const { return ScalarShape(); } Result operator()(const TypeParamInquiry &) const { return ScalarShape(); } Result operator()(const BOZLiteralConstant &) const { return ScalarShape(); } Result operator()(const StaticDataObject::Pointer &) const { diff --git a/flang/include/flang/Evaluate/traverse.h b/flang/include/flang/Evaluate/traverse.h index 44cfaa2a7073d..2cf33201b1409 100644 --- a/flang/include/flang/Evaluate/traverse.h +++ b/flang/include/flang/Evaluate/traverse.h @@ -161,6 +161,9 @@ class Traverse { Result operator()(const DescriptorInquiry &x) const { return visitor_(x.base()); } + Result operator()(const RankOneBoundElement &x) const { + return visitor_(x.base()); + } // Calls Result operator()(const SpecificIntrinsic &) const { diff --git a/flang/include/flang/Evaluate/variable.h b/flang/include/flang/Evaluate/variable.h index 4f64ede3d407d..5b4e70ea0db93 100644 --- a/flang/include/flang/Evaluate/variable.h +++ b/flang/include/flang/Evaluate/variable.h @@ -435,6 +435,34 @@ class DescriptorInquiry { int dimension_{0}; // zero-based }; +// Represents the extraction of a single scalar element from a rank-1 +// integer array expression used as an explicit-shape array bound (F2023). +// The inner expression is rank-1; this node is scalar (Rank() == 0). +// dimension_ is zero-based. +class RankOneBoundElement { +public: + using Result = SubscriptInteger; + CLASS_BOILERPLATE(RankOneBoundElement) + RankOneBoundElement(common::CopyableIndirection> &&e, + int dim) + : base_{std::move(e)}, dimension_{dim} {} + RankOneBoundElement(Expr &&e, int dim) + : base_{std::move(e)}, dimension_{dim} {} + + const Expr &base() const { return base_.value(); } + Expr &base() { return base_.value(); } + int dimension() const { return dimension_; } + + static constexpr int Rank() { return 0; } // always scalar + static constexpr int Corank() { return 0; } + bool operator==(const RankOneBoundElement &) const; + llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const; + +private: + common::CopyableIndirection> base_; + int dimension_{0}; // zero-based +}; + #define INSTANTIATE_VARIABLE_TEMPLATES \ FOR_EACH_SPECIFIC_TYPE(template class Designator, ) } // namespace Fortran::evaluate diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h index 4bfeccfbe5c67..a2204aba01a56 100644 --- a/flang/include/flang/Parser/dump-parse-tree.h +++ b/flang/include/flang/Parser/dump-parse-tree.h @@ -353,6 +353,7 @@ class ParseTreeDumper { NODE(parser, ExitStmt) NODE(parser, ExplicitCoshapeSpec) NODE(parser, ExplicitShapeSpec) + NODE(parser, ExplicitShapeBoundsSpec) NODE(parser, Expr) NODE(Expr, Parentheses) NODE(Expr, UnaryPlus) diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h index a07e47bf92bd1..cdc81c17b2cb6 100644 --- a/flang/include/flang/Parser/parse-tree.h +++ b/flang/include/flang/Parser/parse-tree.h @@ -1326,13 +1326,21 @@ WRAPPER_CLASS(ImpliedShapeSpec, std::list); EMPTY_CLASS(AssumedRankSpec); // R815 array-spec -> -// explicit-shape-spec-list | assumed-shape-spec-list | -// deferred-shape-spec-list | assumed-size-spec | implied-shape-spec | +// explicit-shape-spec-list | explicit-shape-bounds-spec | +// assumed-shape-spec-list | deferred-shape-spec-list | +// assumed-size-spec | implied-shape-spec | // implied-shape-or-assumed-size-spec | assumed-rank-spec + +struct ExplicitShapeBoundsSpec { + TUPLE_CLASS_BOILERPLATE(ExplicitShapeBoundsSpec); + std::tuple, IntExpr> t; +}; + struct ArraySpec { UNION_CLASS_BOILERPLATE(ArraySpec); - std::variant, std::list, - DeferredShapeSpecList, AssumedSizeSpec, ImpliedShapeSpec, AssumedRankSpec> + std::variant, ExplicitShapeBoundsSpec, + std::list, DeferredShapeSpecList, AssumedSizeSpec, + ImpliedShapeSpec, AssumedRankSpec> u; }; diff --git a/flang/include/flang/Semantics/dump-expr.h b/flang/include/flang/Semantics/dump-expr.h index d79a294258ff1..868b64c64e60a 100644 --- a/flang/include/flang/Semantics/dump-expr.h +++ b/flang/include/flang/Semantics/dump-expr.h @@ -149,6 +149,7 @@ class DumpEvaluateExpr { Outdent(); } void Show(const evaluate::DescriptorInquiry &x); + void Show(const evaluate::RankOneBoundElement &x); void Show(const evaluate::SpecificIntrinsic &); void Show(const evaluate::ProcedureDesignator &x); void Show(const evaluate::ActualArgument &x); diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index 62c93e5d20737..1d63c61e2a2f2 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -91,6 +91,9 @@ class IsConstantExprHelper (IsIntentIn(sym) && !IsOptional(sym) && !sym.attrs().test(semantics::Attr::VALUE))); } + bool operator()(const RankOneBoundElement &x) const { + return (*this)(x.base()); + } bool operator()(const ImpliedDoIndex &ido) const { return acImpliedDos_.find(ido.name) != acImpliedDos_.end() || !context_ || @@ -363,6 +366,7 @@ class IsInitialDataTargetHelper IsConstantExpr(x.upper(), context_) && (*this)(x.parent()); } bool operator()(const DescriptorInquiry &) const { return false; } + bool operator()(const RankOneBoundElement &x) const { return false; } // unreachable template bool operator()(const ArrayConstructor &) const { return false; } @@ -798,6 +802,10 @@ class CheckSpecificationExprHelper } } + Result operator()(const RankOneBoundElement &x) const { + return (*this)(x.base()); + } + Result operator()(const TypeParamInquiry &inq) const { if (scope_.IsDerivedType()) { if (!IsConstantExpr(inq, &context_) && @@ -1797,6 +1805,9 @@ class CollectUsedSymbolValuesHelper Result operator()(const DescriptorInquiry &) const { return {}; // doesn't count as a use } + Result operator()(const RankOneBoundElement &x) const { + return {}; // unreachable + } template Result operator()(const ConditionalExpr &condExpr) { auto restorer{common::ScopedSet(isDefinition_, false)}; diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h index 2df2b9e5a300b..5e7e85d33a92f 100644 --- a/flang/lib/Evaluate/fold-implementation.h +++ b/flang/lib/Evaluate/fold-implementation.h @@ -138,6 +138,8 @@ Expr FoldOperation(FoldingContext &context, Designator &&designator) { } Expr FoldOperation( FoldingContext &, TypeParamInquiry &&); +Expr FoldOperation( + FoldingContext &, RankOneBoundElement &&); Expr FoldOperation( FoldingContext &context, ImpliedDoIndex &&); template diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp index 9f2bb94a9213f..bfecf5917f178 100644 --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -1554,6 +1554,20 @@ Expr FoldOperation( return AsExpr(std::move(inquiry)); } +Expr FoldOperation( + FoldingContext &context, RankOneBoundElement &&x) { + using ResultType = RankOneBoundElement::Result; + auto folded{Fold(context, Expr{x.base()})}; + if (auto *c{UnwrapConstantValue(folded)}) { + // Base is a constant array; extract the element at dimension_ (0-based). + ConstantSubscripts at{c->lbounds()}; + at[0] = c->lbounds()[0] + x.dimension(); + return Expr{Constant{c->At(at)}}; + } + return Expr{ + RankOneBoundElement{std::move(folded), x.dimension()}}; +} + std::optional ToInt64(const Expr &expr) { return common::visit( [](const auto &kindExpr) { return ToInt64(kindExpr); }, expr.u); diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp index 09cb8b08dda81..df042afb84958 100644 --- a/flang/lib/Evaluate/formatting.cpp +++ b/flang/lib/Evaluate/formatting.cpp @@ -847,6 +847,12 @@ llvm::raw_ostream &DescriptorInquiry::AsFortran(llvm::raw_ostream &o) const { return o << ",kind=" << DescriptorInquiry::Result::kind << ")"; } +llvm::raw_ostream &RankOneBoundElement::AsFortran( + llvm::raw_ostream &o) const { + llvm_unreachable("RankOneBoundElement has no Fortran representation"); + return o; +} + llvm::raw_ostream &Assignment::AsFortran(llvm::raw_ostream &o) const { common::visit( common::visitors{ diff --git a/flang/lib/Evaluate/variable.cpp b/flang/lib/Evaluate/variable.cpp index b257dad42fc58..b5774ef9fe624 100644 --- a/flang/lib/Evaluate/variable.cpp +++ b/flang/lib/Evaluate/variable.cpp @@ -764,6 +764,9 @@ bool DescriptorInquiry::operator==(const DescriptorInquiry &that) const { return field_ == that.field_ && base_ == that.base_ && dimension_ == that.dimension_; } +bool RankOneBoundElement::operator==(const RankOneBoundElement &that) const { + return dimension_ == that.dimension_ && base_ == that.base_; +} #ifdef _MSC_VER // disable bogus warning about missing definitions #pragma warning(disable : 4661) diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp index 32cd710e9b5b4..30d1108d69b95 100644 --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -1062,6 +1062,10 @@ class ScalarExprLowering { llvm_unreachable("unknown descriptor inquiry"); } + ExtValue genval(const Fortran::evaluate::RankOneBoundElement &) { + llvm_unreachable("RankOneBoundElement in legacy lowering path"); + } + ExtValue genval(const Fortran::evaluate::TypeParamInquiry &) { TODO(getLoc(), "type parameter inquiry"); } @@ -6568,6 +6572,11 @@ class ArrayExprLowering { TODO(getLoc(), "array expr descriptor inquiry"); return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; } + CC genarr(const Fortran::evaluate::RankOneBoundElement &x) { + fir::emitFatalError(getLoc(), + "rank-1 bound element cannot appear in array context"); + return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; + } CC genarr(const Fortran::evaluate::StructureConstructor &x) { TODO(getLoc(), "structure constructor"); return [](IterSpace iters) -> ExtValue { return mlir::Value{}; }; diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp index a57fce53c0ca5..7548eaeb86714 100644 --- a/flang/lib/Lower/ConvertExprToHLFIR.cpp +++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp @@ -1847,6 +1847,27 @@ class HlfirBuilder { llvm_unreachable("unknown descriptor inquiry"); } + hlfir::EntityWithAttributes + gen(const Fortran::evaluate::RankOneBoundElement &x) { + mlir::Location loc = getLoc(); + auto &builder = getBuilder(); + using ResTy = Fortran::evaluate::RankOneBoundElement::Result; + mlir::Type resultType = + getConverter().genType(ResTy::category, ResTy::kind); + // Evaluate the rank-1 base expression. + Fortran::lower::SomeExpr someExpr{Fortran::evaluate::AsGenericExpr( + Fortran::evaluate::Expr{ + Fortran::common::Clone(x.base())})}; + hlfir::Entity baseArray{Fortran::lower::convertExprToHLFIR( + loc, getConverter(), someExpr, getSymMap(), getStmtCtx())}; + // Extract element at dimension (1-based index). + mlir::Value idx = builder.createIntegerConstant( + loc, builder.getIndexType(), x.dimension() + 1); + mlir::Value elem = hlfir::loadElementAt(loc, builder, baseArray, {idx}); + return hlfir::EntityWithAttributes{ + builder.createConvert(loc, resultType, elem)}; + } + /// Build nested if-then-else chain by walking the right-skewed /// ConditionalExpr tree. The assignValue callback generates and assigns /// each value to avoid evaluating non-taken branches. diff --git a/flang/lib/Lower/IterationSpace.cpp b/flang/lib/Lower/IterationSpace.cpp index 52a15223bc1e6..4b085e6eed784 100644 --- a/flang/lib/Lower/IterationSpace.cpp +++ b/flang/lib/Lower/IterationSpace.cpp @@ -166,6 +166,7 @@ class ArrayBaseFinder { return find(x.u); } RT find(const Fortran::evaluate::DescriptorInquiry &) { return {}; } + RT find(const Fortran::evaluate::RankOneBoundElement &) { return {}; } RT find(const Fortran::evaluate::SpecificIntrinsic &) { return {}; } RT find(const Fortran::evaluate::ProcedureDesignator &x) { return {}; } RT find(const Fortran::evaluate::ProcedureRef &x) { diff --git a/flang/lib/Lower/Support/Utils.cpp b/flang/lib/Lower/Support/Utils.cpp index 280968975ea96..c6dbe97a32d12 100644 --- a/flang/lib/Lower/Support/Utils.cpp +++ b/flang/lib/Lower/Support/Utils.cpp @@ -242,6 +242,11 @@ class HashEvaluateExpr { static_cast(x.dimension()); } static unsigned + getHashValue(const Fortran::evaluate::RankOneBoundElement &x) { + return getHashValue(x.base()) * 141u + + static_cast(x.dimension()) * 17u; + } + static unsigned getHashValue(const Fortran::evaluate::StructureConstructor &x) { // FIXME: hash the contents. return 149u; @@ -547,6 +552,10 @@ class IsEqualEvaluateExpr { return isEqual(x.base(), y.base()) && x.field() == y.field() && x.dimension() == y.dimension(); } + static bool isEqual(const Fortran::evaluate::RankOneBoundElement &x, + const Fortran::evaluate::RankOneBoundElement &y) { + return x.dimension() == y.dimension() && isEqual(x.base(), y.base()); + } static bool isEqual(const Fortran::evaluate::StructureConstructor &x, const Fortran::evaluate::StructureConstructor &y) { const auto &xValues = x.values(); diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp index b980a51d3f249..7c566d752135d 100644 --- a/flang/lib/Parser/unparse.cpp +++ b/flang/lib/Parser/unparse.cpp @@ -571,6 +571,10 @@ class UnparseVisitor { common::visit( common::visitors{ [&](const std::list &y) { Walk(y, ","); }, + [&](const ExplicitShapeBoundsSpec &y) { + Walk(std::get>(y.t), ":"); + Walk(std::get(y.t)); + }, [&](const std::list &y) { Walk(y, ","); }, [&](const DeferredShapeSpecList &y) { Walk(y); }, [&](const AssumedSizeSpec &y) { Walk(y); }, diff --git a/flang/lib/Semantics/dump-expr.cpp b/flang/lib/Semantics/dump-expr.cpp index 8d354cf65b61e..44c7d5a4058cf 100644 --- a/flang/lib/Semantics/dump-expr.cpp +++ b/flang/lib/Semantics/dump-expr.cpp @@ -195,6 +195,12 @@ void DumpEvaluateExpr::Show(const evaluate::DescriptorInquiry &x) { Outdent(); } +void DumpEvaluateExpr::Show(const evaluate::RankOneBoundElement &x) { + Indent(("rank-1 bound element [" + llvm::Twine(x.dimension()) + "]").str()); + Show(x.base()); + Outdent(); +} + void DumpEvaluateExpr::Print(llvm::Twine twine) { outs_ << GetIndentString() << twine << '\n'; } diff --git a/flang/lib/Semantics/mod-file.cpp b/flang/lib/Semantics/mod-file.cpp index 3bfe1e144f961..e8b9d665fb2c8 100644 --- a/flang/lib/Semantics/mod-file.cpp +++ b/flang/lib/Semantics/mod-file.cpp @@ -59,6 +59,7 @@ static void PutBound(llvm::raw_ostream &, const Bound &); static void PutShapeSpec(llvm::raw_ostream &, const ShapeSpec &); static void PutShape( llvm::raw_ostream &, const ArraySpec &, char open, char close); +static bool HasRankOneBound(const ArraySpec &); static void PutMapper(llvm::raw_ostream &, const Symbol &, SemanticsContext &); static llvm::raw_ostream &PutAttr(llvm::raw_ostream &, Attr); @@ -974,18 +975,63 @@ void PutShapeSpec(llvm::raw_ostream &os, const ShapeSpec &x) { } } } + +// Check whether any bound in an ArraySpec holds a RankOneBoundElement, +// indicating the shape came from a rank-1 integer array expression. +bool HasRankOneBound(const ArraySpec &shape) { + const auto &first{shape.front()}; + if (auto lb{first.lbound().GetExplicit()}) { + if (evaluate::UnwrapExpr(*lb)) { + return true; + } + } + if (auto ub{first.ubound().GetExplicit()}) { + if (evaluate::UnwrapExpr(*ub)) { + return true; + } + } + return false; +} + void PutShape( llvm::raw_ostream &os, const ArraySpec &shape, char open, char close) { if (!shape.empty()) { os << open; - bool first{true}; - for (const auto &shapeSpec : shape) { - if (first) { - first = false; - } else { - os << ','; + if (HasRankOneBound(shape)) { + // Rank-1 bounds: all ShapeSpecs share the same rank-1 expression + // wrapped in RankOneBoundElement. Extract the base expression from the + // first element and emit it whole so the mod file round-trips through + // the parser as an ExplicitShapeBoundsSpec. + const auto &first{shape.front()}; + if (!first.lbound().isColon()) { + auto lb{first.lbound().GetExplicit()}; + if (auto *robe = + evaluate::UnwrapExpr(*lb)) { + robe->base().AsFortran(os); + } else { + PutBound(os, first.lbound()); + } + } + os << ':'; + if (!first.ubound().isColon()) { + auto ub{first.ubound().GetExplicit()}; + if (auto *robe = + evaluate::UnwrapExpr(*ub)) { + robe->base().AsFortran(os); + } else { + PutBound(os, first.ubound()); + } + } + } else { + bool first{true}; + for (const auto &shapeSpec : shape) { + if (first) { + first = false; + } else { + os << ','; + } + PutShapeSpec(os, shapeSpec); } - PutShapeSpec(os, shapeSpec); } os << close; } diff --git a/flang/lib/Semantics/resolve-names-utils.cpp b/flang/lib/Semantics/resolve-names-utils.cpp index ef34c89182f7f..9040bbcc3f1a5 100644 --- a/flang/lib/Semantics/resolve-names-utils.cpp +++ b/flang/lib/Semantics/resolve-names-utils.cpp @@ -203,6 +203,7 @@ class ArraySpecAnalyzer { } void Analyze(const parser::AssumedShapeSpec &); void Analyze(const parser::ExplicitShapeSpec &); + void Analyze(const parser::ExplicitShapeBoundsSpec &); void Analyze(const parser::AssumedImpliedSpec &); void Analyze(const parser::DeferredShapeSpecList &); void Analyze(const parser::AssumedRankSpec &); @@ -212,6 +213,12 @@ class ArraySpecAnalyzer { void MakeDeferred(int); Bound GetBound(const std::optional &); Bound GetBound(const parser::SpecificationExpr &); + struct ExplicitShapeBoundsResult { + Bound ubound; + std::optional lbound; + std::int64_t numDims; + }; + std::optional checkExplicitShapeBoundsSpec(const parser::ExplicitShapeBoundsSpec &x); }; ArraySpec AnalyzeArraySpec( @@ -237,7 +244,67 @@ ArraySpec ArraySpecAnalyzer::Analyze(const parser::ComponentArraySpec &x) { CHECK(!arraySpec_.empty()); return arraySpec_; } + +static bool shouldRewriteShapeSpecListToExplicitBounds( + SemanticsContext &context, const parser::ArraySpec &x) { + auto &explicitShapeSpecList{ + std::get>(x.u)}; + + if (explicitShapeSpecList.size() != 1) { + return false; + } + + auto &explicitShapeSpec{explicitShapeSpecList.front()}; + const auto &upperBound{std::get<1>(explicitShapeSpec.t)}; + const auto &lowerBoundOpt{std::get<0>(explicitShapeSpec.t)}; + + bool foundArray{false}; + + if (MaybeExpr analyzedExpr = + AnalyzeExpr(context, parser::UnwrapRef(upperBound)); + analyzedExpr && (analyzedExpr->Rank() > 0)) { + foundArray = true; + } + + if (lowerBoundOpt) { + const auto &lowerBound{*lowerBoundOpt}; + if (MaybeExpr analyzedExpr = + AnalyzeExpr(context, parser::UnwrapRef(lowerBound)); + analyzedExpr && (analyzedExpr->Rank() > 0)) { + foundArray = true; + } + } + + return foundArray; +} + +static void rewriteShapeSpecListToExplicitBounds(const parser::ArraySpec &x) { + auto &explicitShapeSpecList{std::get>( + const_cast(x).u)}; + auto &mutableArraySpec{const_cast(x)}; + auto &mutableExplicitShapeSpec{explicitShapeSpecList.front()}; + + auto &mutableUpperBound{std::get<1>(mutableExplicitShapeSpec.t)}; + parser::IntExpr upperIntExpr{std::move(mutableUpperBound.v.thing)}; + + auto &mutableLowerBound{std::get<0>(mutableExplicitShapeSpec.t)}; + std::optional lowerIntExpr; + if (mutableLowerBound) { + lowerIntExpr = std::move(mutableLowerBound->v.thing); + } + + parser::ExplicitShapeBoundsSpec boundsSpec{ + std::make_tuple(std::move(lowerIntExpr), std::move(upperIntExpr))}; + mutableArraySpec.u = std::move(boundsSpec); + + return; +} + ArraySpec ArraySpecAnalyzer::Analyze(const parser::ArraySpec &x) { + if (std::get_if>(&x.u) && + shouldRewriteShapeSpecListToExplicitBounds(context_, x)) { + rewriteShapeSpecListToExplicitBounds(x); + } common::visit(common::visitors{ [&](const parser::AssumedSizeSpec &y) { Analyze( @@ -279,6 +346,141 @@ void ArraySpecAnalyzer::Analyze(const parser::ExplicitShapeSpec &x) { MakeExplicit(std::get>(x.t), std::get(x.t)); } + + +std::optional +ArraySpecAnalyzer::checkExplicitShapeBoundsSpec( + const parser::ExplicitShapeBoundsSpec &x) { + const auto &lowerBoundOpt{std::get<0>(x.t)}; + const auto &upperBound{std::get<1>(x.t)}; + + // Analyze, validate, fold, and wrap one bound expression in a Bound. + // Returns the Bound and, for rank-1, the constant extent; for scalar + // the extent is 0 (meaning "broadcast"). + bool hasError{false}; + auto analyzeBound = [&](const auto &parseBound, bool isUpper) + -> std::optional> { + MaybeExpr expr{AnalyzeExpr(context_, parseBound.thing)}; + if (expr->Rank() > 1) { + context_.Say(parser::FindSourceLocation(parseBound), + "Integer array used as %s bounds in DECLARATION must be rank-1 " + "but is rank-%d"_err_en_US, + isUpper ? "upper" : "lower", expr->Rank()); + hasError = true; + return std::nullopt; + } + auto folded{evaluate::Fold(context_.foldingContext(), std::move(*expr))}; + const auto *someInt{evaluate::UnwrapExpr(folded)}; + if (!someInt) { + hasError = true; + return std::nullopt; + } + auto asSI{evaluate::Fold(context_.foldingContext(), + evaluate::ConvertToType( + common::Clone(*someInt)))}; + if (folded.Rank() == 0) { + return std::make_pair( + Bound{MaybeSubscriptIntExpr{std::move(asSI)}}, std::int64_t{0}); + } + // Rank-1: must have constant extent. + auto extents{ + evaluate::GetConstantExtents(context_.foldingContext(), folded)}; + if (!extents) { + context_.Say(parser::FindSourceLocation(parseBound), + "Rank-1 integer array used as %s bounds in DECLARATION must " + "have constant size"_err_en_US, + isUpper ? "upper" : "lower"); + hasError = true; + return std::nullopt; + } + return std::make_pair( + Bound{MaybeSubscriptIntExpr{std::move(asSI)}}, (*extents)[0]); + }; + + // Upper bound (required) + auto ubResult{analyzeBound(upperBound, /*isUpper=*/true)}; + + // Lower bound (optional) + std::optional> lbResult; + if (lowerBoundOpt) { + lbResult = analyzeBound(*lowerBoundOpt, /*isUpper=*/false); + } + + if (hasError) { + return std::nullopt; + } + + std::int64_t ubExtent{ubResult->second}; + std::int64_t lbExtent{lbResult ? lbResult->second : 0}; + + // Determine numDims from whichever is rank-1 (extent > 0). + std::int64_t numDims{std::max(ubExtent, lbExtent)}; + + // Size mismatch check (only when both are rank-1). + if (ubExtent > 0 && lbExtent > 0 && ubExtent != lbExtent) { + context_.Say(parser::FindSourceLocation(x), + "DECLARATION bounds integer rank-1 arrays must have the same size; " + "lower bounds has %jd elements, upper bounds has %jd elements"_err_en_US, + lbExtent, ubExtent); + return std::nullopt; + } + + std::optional lb; + if (lbResult) { + lb.emplace(std::move(lbResult->first)); + } + return ExplicitShapeBoundsResult{ + std::move(ubResult->first), std::move(lb), numDims}; +} + +void ArraySpecAnalyzer::Analyze(const parser::ExplicitShapeBoundsSpec &x) { + auto result{checkExplicitShapeBoundsSpec(x)}; + // Every path that results in result being false emits an error. In the event + // that we bail early without emitting an error, we silently pass the fallback + // Bound{1} WITHOUT failing. This check ensures that if we failed, we emitted + // an error message. This way we can pass the + // CHECK(!arraySpec_.empty()); + // in Analyze(ArraySpec). If we don't, it'll crash before getting to emit + // the real (user) error messages. + if (!result) { + CHECK(context_.AnyFatalError()); + arraySpec_.push_back(ShapeSpec::MakeExplicit(Bound{1})); + return; + } + // For rank-1 bounds, emit N ShapeSpecs each wrapping a scalar + // RankOneBoundElement that extracts element [dim] from the rank-1 + // expression. This makes all downstream consumers see scalar bounds. + int numDims = static_cast(result->numDims); + for (int dim = 0; dim < numDims; ++dim) { + // Upper bound + MaybeSubscriptIntExpr ubExpr; + if (auto &ubOrig = result->ubound.GetExplicit()) { + if (ubOrig->Rank() > 0) { + ubExpr = SubscriptIntExpr{evaluate::RankOneBoundElement{ + common::Clone(*ubOrig), dim}}; + } else { + ubExpr = common::Clone(*ubOrig); + } + } + // Lower bound + MaybeSubscriptIntExpr lbExpr; + if (result->lbound) { + if (auto &lbOrig = result->lbound->GetExplicit()) { + if (lbOrig->Rank() > 0) { + lbExpr = SubscriptIntExpr{evaluate::RankOneBoundElement{ + common::Clone(*lbOrig), dim}}; + } else { + lbExpr = common::Clone(*lbOrig); + } + } + } + Bound lb{lbExpr ? std::move(lbExpr) + : MaybeSubscriptIntExpr{SubscriptIntExpr{1}}}; + Bound ub{std::move(ubExpr)}; + arraySpec_.push_back(ShapeSpec::MakeExplicit(std::move(lb), std::move(ub))); + } +} + void ArraySpecAnalyzer::Analyze(const parser::AssumedImpliedSpec &x) { MakeImplied(x.v); } diff --git a/flang/test/Lower/HLFIR/explicit-shape-bounds.f90 b/flang/test/Lower/HLFIR/explicit-shape-bounds.f90 new file mode 100644 index 0000000000000..5cfc6c47e9d2c --- /dev/null +++ b/flang/test/Lower/HLFIR/explicit-shape-bounds.f90 @@ -0,0 +1,79 @@ +! Test lowering of explicit-shape bounds using rank-1 integer arrays +! (RankOneBoundElement in the evaluate representation). +! RUN: bbc -emit-hlfir -o - %s 2>&1 | FileCheck %s + +! Test with PARAMETER rank-1 bounds (should fold to scalar constants via array indexing) +module test_param +contains + subroutine test_param_bounds() + integer, parameter :: dims(3) = [2, 3, 4] + real :: a(dims) + a(1,1,1) = 1.0 + end subroutine +end module +! CHECK-LABEL: func.func @_QMtest_paramPtest_param_bounds() +! CHECK: hlfir.designate {{.*}} (%c1{{.*}}) : ({{.*}}, index) -> !fir.ref +! CHECK: fir.load {{.*}} : !fir.ref +! CHECK: fir.convert {{.*}} : (i64) -> index + +! Test with rank-1 dummy as upper bounds only. +module test_dummy_upper +contains + subroutine test_dummy_upper_bounds(n) + integer, intent(in) :: n(3) + real :: a(n) + a(1,1,1) = 1.0 + end subroutine +end module +! CHECK-LABEL: func.func @_QMtest_dummy_upperPtest_dummy_upper_bounds( +! CHECK: hlfir.elemental {{.*}} -> !hlfir.expr<3xi64> +! CHECK: ^bb0(%arg{{.*}}: index): +! CHECK: hlfir.designate {{.*}} (%arg{{.*}}) : ({{.*}}, index) -> !fir.ref +! CHECK: fir.load {{.*}} : !fir.ref +! CHECK: fir.convert {{.*}} : (i32) -> i64 +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: hlfir.apply {{.*}}, %[[C1]] : (!hlfir.expr<3xi64>, index) -> i64 +! CHECK: %[[C2:.*]] = arith.constant 2 : index +! CHECK: hlfir.apply {{.*}}, %[[C2]] : (!hlfir.expr<3xi64>, index) -> i64 +! CHECK: %[[C3:.*]] = arith.constant 3 : index +! CHECK: hlfir.apply {{.*}}, %[[C3]] : (!hlfir.expr<3xi64>, index) -> i64 + +! Test with both lower and upper rank-1 bounds. +module test_dummy_both +contains + subroutine test_dummy_both_bounds(lb, ub) + integer, intent(in) :: lb(2), ub(2) + real :: a(lb:ub) + a(1,1) = 1.0 + end subroutine +end module +! CHECK-LABEL: func.func @_QMtest_dummy_bothPtest_dummy_both_bounds( +! CHECK: hlfir.elemental {{.*}} -> !hlfir.expr<2xi64> +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: hlfir.apply {{.*}}, %[[C1]] : (!hlfir.expr<2xi64>, index) -> i64 +! CHECK: hlfir.elemental {{.*}} -> !hlfir.expr<2xi64> +! CHECK: %[[C1_1:.*]] = arith.constant 1 : index +! CHECK: hlfir.apply {{.*}}, %[[C1_1]] : (!hlfir.expr<2xi64>, index) -> i64 +! CHECK: hlfir.elemental {{.*}} -> !hlfir.expr<2xi64> +! CHECK: %[[C2:.*]] = arith.constant 2 : index +! CHECK: hlfir.apply {{.*}}, %[[C2]] : (!hlfir.expr<2xi64>, index) -> i64 +! CHECK: hlfir.elemental {{.*}} -> !hlfir.expr<2xi64> +! CHECK: %[[C2_1:.*]] = arith.constant 2 : index +! CHECK: hlfir.apply {{.*}}, %[[C2_1]] : (!hlfir.expr<2xi64>, index) -> i64 + +! Test broadcast of scalar lower bound with rank-1 upper bounds. +module test_broadcast +contains + subroutine test_broadcast_bounds(ub) + integer, intent(in) :: ub(2) + real :: a(0:ub) + a(0,0) = 1.0 + end subroutine +end module +! CHECK-LABEL: func.func @_QMtest_broadcastPtest_broadcast_bounds( +! CHECK: hlfir.elemental {{.*}} -> !hlfir.expr<2xi64> +! CHECK: %[[U1:.*]] = arith.constant 1 : index +! CHECK: hlfir.apply {{.*}}, %[[U1]] : (!hlfir.expr<2xi64>, index) -> i64 +! CHECK: %[[U2:.*]] = arith.constant 2 : index +! CHECK: hlfir.apply {{.*}}, %[[U2]] : (!hlfir.expr<2xi64>, index) -> i64 +! CHECK: fir.shape_shift {{.*}} : (index, index, index, index) -> !fir.shapeshift<2> diff --git a/flang/test/Semantics/declaration-explicit-array-bounds.f90 b/flang/test/Semantics/declaration-explicit-array-bounds.f90 new file mode 100644 index 0000000000000..5ef4ed3eceed8 --- /dev/null +++ b/flang/test/Semantics/declaration-explicit-array-bounds.f90 @@ -0,0 +1,146 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -Wautomatic-in-main-program -Wsaved-local-in-spec-expr +! ---- Module with rank-1 array-bounded declarations, USE'd elsewhere ---- +subroutine array_flatten(int) + integer, intent(IN) :: int + !Array Constructors produce rank-1 arrays, even with nested arrays, + !so neither of these should produce an error or warning. + integer :: fff([int, int]) + integer :: ff([[int, [int, int]]]) + integer :: arr([(int+i, integer(8) :: i=1_8, 2_8)]) +end subroutine +module getter +contains + pure function get_bounds() result(r) + integer :: r(2) + r = [8, 9] + end function + subroutine foo() + ! Function result (rank-1 integer array) as explicit shape bounds + integer :: from_func(get_bounds()) + end subroutine +end module +module bounds_provider + implicit none + integer, parameter :: dims(3) = [5, 5, 5] + integer, parameter :: lo(2) = [2, 3] + integer, parameter :: hi(2) = [10, 20] +end module +module consumer + use bounds_provider + implicit none + ! Declare arrays using USE-associated rank-1 parameter arrays + integer :: arr_upper(dims) + integer :: arr_both(lo : hi) +end module +subroutine sub_consumer() + use bounds_provider, only: dims, lo, hi + implicit none + ! USE'd parameter arrays as bounds in a subroutine + integer :: local_arr(dims) + integer :: local_arr2(lo : hi) +end subroutine +subroutine sub_use_consumer() + use consumer, only: arr_upper, arr_both + implicit none + ! USE the arrays that were themselves declared with rank-1 array bounds + arr_upper = 1 + arr_both = 2 +end subroutine +subroutine bar(n, bounds, rank_bounds) + integer, intent(IN) :: n + integer, intent(IN) :: bounds(:) + integer, intent(IN) :: rank_bounds(..) + integer :: bounds2(n) + !ERROR: Rank-1 integer array used as upper bounds in DECLARATION must have constant size + integer :: arr(bounds) + !ERROR: Rank-1 integer array used as upper bounds in DECLARATION must have constant size + integer :: arr2(bounds2) + !ERROR: Rank-1 integer array used as upper bounds in DECLARATION must have constant size + integer :: arr3(rank_bounds) +end subroutine + +module data + integer :: rank1_array_module(3) = [5, 5, 5] + !ERROR: Automatic data object 'gg2' may not appear in a module + integer :: gg2(rank1_array_module) + integer, allocatable :: nonconstsize(:) + !ERROR: Rank-1 integer array used as lower bounds in DECLARATION must have constant size + !ERROR: Rank-1 integer array used as upper bounds in DECLARATION must have constant size + integer :: gg3(nonconstsize : nonconstsize) +end module +program declaration_array_bounds + use getter + implicit none + + ! Valid cases (no errors expected) + + ! Array upper bound only + integer :: c([3, 4, 5]) + integer, dimension([3, 4, 5]) :: cc + + ! Array lower and upper bounds, same size + integer :: d((/2, 3/) : [10, 20]) + + ! Scalar lower, array upper + integer :: e(2 : [10, 20]) + + ! Array lower, scalar upper + integer :: f([2, 3] : 10) + + ! Using non-literal PARAMETER variables + integer, parameter :: rank1_parameter_array(3) = [5,5,5] + integer :: g(rank1_parameter_array) + integer :: ggg(rank1_parameter_array * 2 : rank1_parameter_array - 1) + + + ! Negative cases (erros expected) + integer :: rank1_array(3) = [5,5,5] + ! Use existing error message for constness checking + !PORTABILITY: specification expression refers to local object 'rank1_array' (initialized and saved) [-Wsaved-local-in-spec-expr] + !PORTABILITY: Automatic data object 'gg' should not appear in the specification part of a main program [-Wautomatic-in-main-program] + integer :: gg(rank1_array) + integer :: scalar + !ERROR: Invalid specification expression: reference to local entity 'scalar' + !PORTABILITY: Automatic data object 'gggg' should not appear in the specification part of a main program [-Wautomatic-in-main-program] + integer :: gggg(rank1_parameter_array : scalar) + + !ERROR: Must have INTEGER type, but is REAL(4) + integer :: h([1.2,2.2,3.2]:[1,2,3]) + !ERROR: DECLARATION bounds integer rank-1 arrays must have the same size; lower bounds has 3 elements, upper bounds has 2 elements + integer :: i([1,2,3]:[3,3]) + !Previously uncaught bug: array of size 1 is being treated as a scalar, and broadcast. This is incorrect. + !It should be treated as a size mismatch error like the one above. + !ERROR: DECLARATION bounds integer rank-1 arrays must have the same size; lower bounds has 1 elements, upper bounds has 2 elements + integer :: ii([1] : [1,2]) + !Test same behavior with vector subscripts + !ERROR: DECLARATION bounds integer rank-1 arrays must have the same size; lower bounds has 1 elements, upper bounds has 2 elements + integer :: abc(rank1_array([scalar]) : rank1_array([scalar, scalar])) + !Test same behavior with array slices + !ERROR: DECLARATION bounds integer rank-1 arrays must have the same size; lower bounds has 2 elements, upper bounds has 1 elements + integer :: abcd(rank1_array(1:3:2) : rank1_array(1:1)) + ! using a nonconst upper bound or stride for array slices makes the size nonconst. Should error + !ERROR: Rank-1 integer array used as upper bounds in DECLARATION must have constant size + integer :: abcde(rank1_parameter_array(1:scalar:1)) + !ERROR: Rank-1 integer array used as upper bounds in DECLARATION must have constant size + integer :: abcdef(rank1_parameter_array(1:1:scalar)) + + ! Test error for rank > 1, fulfilling constness + integer, parameter :: rank2_parameter_array(2,2) = reshape([[1,2],[3,4]], [2,2]) + !ERROR: Integer array used as upper bounds in DECLARATION must be rank-1 but is rank-2 + integer :: j(rank2_parameter_array) + ! Test combined bounds error, first bound as before but second bound as wrong rank + ! and nonconst + integer :: rank3_array(2,2,2) + !ERROR: Integer array used as lower bounds in DECLARATION must be rank-1 but is rank-2 + !ERROR: Integer array used as upper bounds in DECLARATION must be rank-1 but is rank-3 + integer :: k(rank2_parameter_array : rank3_array) + + ! Test that any comma list is parsed as ExplicitShapeSpecList and not rewritten + ! to ExplicitShapeBonudsSpec, giving error messages expecting same number of + ! aruments as rank of test_array and scalar integers + !ERROR: Must be a scalar value, but is a rank-1 array + !ERROR: Must be a scalar value, but is a rank-1 array + !ERROR: Must be a scalar value, but is a rank-1 array + !ERROR: Must have INTEGER type, but is REAL(4) + integer :: test_array([1,2,3] : [2,3,4], 3, [1,2,3], 5.2) +end program diff --git a/flang/test/Semantics/modfile-explicit-shape-bounds.f90 b/flang/test/Semantics/modfile-explicit-shape-bounds.f90 new file mode 100644 index 0000000000000..49fe5348f178a --- /dev/null +++ b/flang/test/Semantics/modfile-explicit-shape-bounds.f90 @@ -0,0 +1,52 @@ +! RUN: %python %S/test_modfile.py %s %flang_fc1 +! Test mod-file generation for F2023 explicit-shape bounds using rank-1 +! integer arrays (ExplicitShapeBoundsSpec / RankOneBoundElement). + +! PARAMETER rank-1 array as upper bounds +module m1 + integer, parameter :: dims(3) = [5, 10, 15] + real :: a(dims) +end module + +!Expect: m1.mod +!module m1 +!integer(4),parameter::dims(1_8:3_8)=[INTEGER(4)::5_4,10_4,15_4] +!real(4)::a(1_8:[INTEGER(8)::5_8,10_8,15_8]) +!end + +! Rank-1 dummy as upper bounds +module m2 +contains +subroutine sub1(n,a) + integer, intent(in) :: n(3) + real :: a(n) +end subroutine +end module + +!Expect: m2.mod +!module m2 +!contains +!subroutine sub1(n,a) +!integer(4),intent(in)::n(1_8:3_8) +!real(4)::a(1_8:int(n,kind=8)) +!end +!end + +! Both lower and upper rank-1 bounds +module m3 +contains +subroutine sub2(lb,ub,a) + integer, intent(in) :: lb(2), ub(2) + real :: a(lb:ub) +end subroutine +end module + +!Expect: m3.mod +!module m3 +!contains +!subroutine sub2(lb,ub,a) +!integer(4),intent(in)::lb(1_8:2_8) +!integer(4),intent(in)::ub(1_8:2_8) +!real(4)::a(int(lb,kind=8):int(ub,kind=8)) +!end +!end diff --git a/flang/test/Semantics/unparse-explicit-array-bounds.f90 b/flang/test/Semantics/unparse-explicit-array-bounds.f90 new file mode 100644 index 0000000000000..9e156285f98c0 --- /dev/null +++ b/flang/test/Semantics/unparse-explicit-array-bounds.f90 @@ -0,0 +1,42 @@ +! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s + +! Test unparse of ExplicitShapeBoundsSpec (rank-1 integer array bounds). + +! Upper bounds only: SHAPE(src) +subroutine ub_only(src) + integer, intent(in) :: src(:,:) + integer :: a(SHAPE(src)) + a = 1 +end subroutine +!CHECK: INTEGER a([INTEGER(4)::int(size(src,dim=1,kind=8),kind=4),int(size(src,dim=2,kind=8),kind=4)]) + +! Lower and upper bounds: lb:ub +subroutine lb_and_ub(lb, ub) + integer, intent(in) :: lb(2), ub(2) + integer :: a(lb:ub) + a = 1 +end subroutine +!CHECK: INTEGER a(lb:ub) + +! Expression bounds: two*SHAPE(src) +subroutine expr_bounds(src) + integer, intent(in) :: src(:,:,:) + integer :: two = 2 + integer :: a(two*SHAPE(src)) + integer :: dims(3) = [2,3,4] + integer :: b(two * dims) + integer :: c(two*SHAPE(src) : two * dims) + a = 1 +end subroutine +!SHAPE can be folded, but dims cannot. Check unparsing for both, then mix them. +!CHECK: INTEGER a([INTEGER(4)::two*int(size(src,dim=1,kind=8),kind=4),two*int(size(src,dim=2,kind=8),kind=4),two*int(size(src,dim=3,kind=8),kind=4)]) +!CHECK: INTEGER b(two*dims) +!CHECK: INTEGER c([INTEGER(4)::two*int(size(src,dim=1,kind=8),kind=4),two*int(size(src,dim=2,kind=8),kind=4),two*int(size(src,dim=3,kind=8),kind=4)]:two*dims) + +! Parameter bounds +subroutine param_bounds() + integer, parameter :: dims(3) = [2, 3, 4] + integer :: a(dims) + a = 1 +end subroutine +!CHECK: INTEGER a([INTEGER(4)::2_4,3_4,4_4])