diff --git a/flang/include/flang/Evaluate/constant.h b/flang/include/flang/Evaluate/constant.h --- a/flang/include/flang/Evaluate/constant.h +++ b/flang/include/flang/Evaluate/constant.h @@ -63,12 +63,23 @@ explicit ConstantBounds(ConstantSubscripts &&shape); ~ConstantBounds(); const ConstantSubscripts &shape() const { return shape_; } + int Rank() const { return GetRank(shape_); } + Constant SHAPE() const; + + // It is possible in this representation for a constant array to have + // lower bounds other than 1, which is of course not expressible in + // Fortran. This case arises only from definitions of named constant + // arrays with such bounds, as in: + // REAL, PARAMETER :: NAMED(0:1) = [1.,2.] + // Bundling the lower bounds of the named constant with its + // constant value allows folding of subscripted array element + // references, LBOUND, and UBOUND without having to thread the named + // constant or its bounds throughout folding. const ConstantSubscripts &lbounds() const { return lbounds_; } ConstantSubscripts ComputeUbounds(std::optional dim) const; void set_lbounds(ConstantSubscripts &&); void SetLowerBoundsToOne(); - int Rank() const { return GetRank(shape_); } - Constant SHAPE() const; + bool HasNonDefaultLowerBound() const; // If no optional dimension order argument is passed, increments a vector of // subscripts in Fortran array order (first dimension varying most quickly). diff --git a/flang/lib/Evaluate/constant.cpp b/flang/lib/Evaluate/constant.cpp --- a/flang/lib/Evaluate/constant.cpp +++ b/flang/lib/Evaluate/constant.cpp @@ -56,6 +56,15 @@ return AsConstantShape(shape_); } +bool ConstantBounds::HasNonDefaultLowerBound() const { + for (auto n : lbounds_) { + if (n != 1) { + return true; + } + } + return false; +} + ConstantSubscript ConstantBounds::SubscriptsToOffset( const ConstantSubscripts &index) const { CHECK(GetRank(index) == GetRank(shape_)); diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h --- a/flang/lib/Evaluate/fold-implementation.h +++ b/flang/lib/Evaluate/fold-implementation.h @@ -255,11 +255,11 @@ const std::vector> *subscripts) { if (auto scalar{structures.GetScalarValue()}) { if (std::optional> expr{scalar->Find(component)}) { - if (const Constant *value{UnwrapConstantValue(expr.value())}) { - if (!subscripts) { - return std::move(*value); - } else { + if (const Constant *value{UnwrapConstantValue(*expr)}) { + if (subscripts) { return ApplySubscripts(*value, *subscripts); + } else { + return *value; } } } diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -126,7 +126,7 @@ } template ConstantSubscripts Get(const Parentheses &x) { - // Cause of temp variable inside parentheses - return [1, ... 1] for lower + // Case of temp variable inside parentheses - return [1, ... 1] for lower // bounds and shape for upper bounds if (getLbound_) { return ConstantSubscripts(x.Rank(), ConstantSubscript{1}); diff --git a/flang/lib/Evaluate/formatting.cpp b/flang/lib/Evaluate/formatting.cpp --- a/flang/lib/Evaluate/formatting.cpp +++ b/flang/lib/Evaluate/formatting.cpp @@ -19,23 +19,35 @@ namespace Fortran::evaluate { -static void ShapeAsFortran( - llvm::raw_ostream &o, const ConstantSubscripts &shape) { - if (GetRank(shape) > 1) { +static void ShapeAsFortran(llvm::raw_ostream &o, + const ConstantSubscripts &shape, const ConstantSubscripts &lbounds, + bool hasNonDefaultLowerBound) { + if (GetRank(shape) > 1 || hasNonDefaultLowerBound) { o << ",shape="; char ch{'['}; for (auto dim : shape) { o << ch << dim; ch = ','; } - o << "])"; + o << ']'; + if (hasNonDefaultLowerBound) { + o << ",%lbound="; + ch = '['; + for (auto lb : lbounds) { + o << ch << lb; + ch = ','; + } + o << ']'; + } + o << ')'; } } template llvm::raw_ostream &ConstantBase::AsFortran( llvm::raw_ostream &o) const { - if (Rank() > 1) { + bool hasNonDefaultLowerBound{HasNonDefaultLowerBound()}; + if (Rank() > 1 || hasNonDefaultLowerBound) { o << "reshape("; } if (Rank() > 0) { @@ -71,14 +83,15 @@ if (Rank() > 0) { o << ']'; } - ShapeAsFortran(o, shape()); + ShapeAsFortran(o, shape(), lbounds(), hasNonDefaultLowerBound); return o; } template llvm::raw_ostream &Constant>::AsFortran( llvm::raw_ostream &o) const { - if (Rank() > 1) { + bool hasNonDefaultLowerBound{HasNonDefaultLowerBound()}; + if (Rank() > 1 || hasNonDefaultLowerBound) { o << "reshape("; } if (Rank() > 0) { @@ -98,7 +111,7 @@ if (Rank() > 0) { o << ']'; } - ShapeAsFortran(o, shape()); + ShapeAsFortran(o, shape(), lbounds(), hasNonDefaultLowerBound); return o; } diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -314,7 +314,7 @@ DescriptorInquiry::Field::LowerBound, dimension_}}; } } else { - auto exprLowerBound{((*this)(assoc->expr()))}; + Result exprLowerBound{((*this)(assoc->expr()))}; if (IsActuallyConstant(exprLowerBound)) { return std::move(exprLowerBound); } else { @@ -334,8 +334,8 @@ } } - Result operator()(const Symbol &symbol0) const { - return GetLowerBound(symbol0, NamedEntity{symbol0}); + Result operator()(const Symbol &symbol) const { + return GetLowerBound(symbol, NamedEntity{symbol}); } Result operator()(const Component &component) const { @@ -346,8 +346,30 @@ return Result{1}; } + template Result operator()(const Expr &expr) const { + if (const Symbol * whole{UnwrapWholeSymbolOrComponentDataRef(expr)}) { + return (*this)(*whole); + } else if constexpr (common::HasMember, decltype(expr.u)>) { + if (const auto *con{std::get_if>(&expr.u)}) { + ConstantSubscripts lb{con->lbounds()}; + if (dimension_ < GetRank(lb)) { + return Result{lb[dimension_]}; + } + } else { // operation + return Result{1}; + } + } else { + return (*this)(expr.u); + } + if constexpr (LBOUND_SEMANTICS) { + return Result{}; + } else { + return Result{1}; + } + } + private: - int dimension_; + int dimension_; // zero-based FoldingContext *context_{nullptr}; }; @@ -618,16 +640,27 @@ if (auto ubound{GetExplicitUBOUND(context, shapeSpec)}) { return *ubound; } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) { - return std::nullopt; + return std::nullopt; // UBOUND() folding replaces with -1 } else if (auto lb{GetLBOUND(base, dimension)}) { return ComputeUpperBound(std::move(*lb), GetExtent(base, dimension)); } } } else if (const auto *assoc{ symbol.detailsIf()}) { - if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) { - if (auto lb{GetLBOUND(base, dimension)}) { - return ComputeUpperBound(std::move(*lb), std::move(extent)); + if (assoc->rank()) { // SELECT RANK case + const Symbol &resolved{ResolveAssociations(symbol)}; + if (IsDescriptor(resolved) && dimension < *assoc->rank()) { + ExtentExpr lb{DescriptorInquiry{NamedEntity{base}, + DescriptorInquiry::Field::LowerBound, dimension}}; + ExtentExpr extent{DescriptorInquiry{ + std::move(base), DescriptorInquiry::Field::Extent, dimension}}; + return ComputeUpperBound(std::move(lb), std::move(extent)); + } + } else if (assoc->expr()) { + if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) { + if (auto lb{GetLBOUND(base, dimension)}) { + return ComputeUpperBound(std::move(*lb), std::move(extent)); + } } } } @@ -644,29 +677,12 @@ } static Shape GetUBOUNDs(FoldingContext *context, const NamedEntity &base) { - const Symbol &symbol{ - ResolveAssociationsExceptSelectRank(base.GetLastSymbol())}; - if (const auto *details{symbol.detailsIf()}) { - Shape result; - int dim{0}; - for (const auto &shapeSpec : details->shape()) { - if (auto ubound{GetExplicitUBOUND(context, shapeSpec)}) { - result.emplace_back(*ubound); - } else if (details->IsAssumedSize() && dim + 1 == base.Rank()) { - result.emplace_back(std::nullopt); // UBOUND folding replaces with -1 - } else if (auto lb{GetLBOUND(base, dim)}) { - result.emplace_back( - ComputeUpperBound(std::move(*lb), GetExtent(base, dim))); - } else { - result.emplace_back(); // unknown - } - ++dim; - } - CHECK(GetRank(result) == symbol.Rank()); - return result; - } else { - return std::move(GetShape(symbol).value()); + Shape result; + int rank{base.Rank()}; + for (int dim{0}; dim < rank; ++dim) { + result.emplace_back(GetUBOUND(context, base, dim)); } + return result; } Shape GetUBOUNDs(FoldingContext &context, const NamedEntity &base) { 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 @@ -311,9 +311,10 @@ void ExpressionAnalyzer::CheckConstantSubscripts(ArrayRef &ref) { // Fold subscript expressions and check for an empty triplet. - Shape lb{GetLBOUNDs(foldingContext_, ref.base())}; + const Symbol &arraySymbol{ref.base().GetLastSymbol()}; + Shape lb{GetLBOUNDs(foldingContext_, NamedEntity{arraySymbol})}; CHECK(lb.size() >= ref.subscript().size()); - Shape ub{GetUBOUNDs(foldingContext_, ref.base())}; + Shape ub{GetUBOUNDs(foldingContext_, NamedEntity{arraySymbol})}; CHECK(ub.size() >= ref.subscript().size()); bool anyPossiblyEmptyDim{false}; int dim{0}; diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp --- a/flang/lib/Semantics/resolve-names.cpp +++ b/flang/lib/Semantics/resolve-names.cpp @@ -8599,8 +8599,7 @@ auto origDetails{origComp.get()}; if (const MaybeExpr & init{origDetails.init()}) { SomeExpr newInit{*init}; - MaybeExpr folded{ - evaluate::Fold(foldingContext, std::move(newInit))}; + MaybeExpr folded{FoldExpr(std::move(newInit))}; details->set_init(std::move(folded)); } } diff --git a/flang/test/Lower/HLFIR/constant.f90 b/flang/test/Lower/HLFIR/constant.f90 --- a/flang/test/Lower/HLFIR/constant.f90 +++ b/flang/test/Lower/HLFIR/constant.f90 @@ -42,11 +42,11 @@ subroutine test_constant_with_lower_bounds() integer, parameter :: i(-1:0, -1:0) = reshape([1,2,3,4], shape=[2,2]) print *, i -! CHECK: %[[VAL_12:.*]] = fir.address_of(@_QQro[[name:.*]]) : !fir.ref> -! CHECK: %[[VAL_13:.*]] = arith.constant 2 : index +! CHECK: %[[VAL_12:.*]] = fir.address_of(@_QFtest_constant_with_lower_boundsECi) : !fir.ref> +! CHECK: %[[VAL_13:.*]] = arith.constant -1 : index ! CHECK: %[[VAL_14:.*]] = arith.constant 2 : index ! CHECK: %[[VAL_15:.*]] = arith.constant -1 : index -! CHECK: %[[VAL_16:.*]] = arith.constant -1 : index -! CHECK: %[[VAL_17:.*]] = fir.shape_shift %[[VAL_15]], %[[VAL_13]], %[[VAL_16]], %[[VAL_14]] : (index, index, index, index) -> !fir.shapeshift<2> -! CHECK: hlfir.declare %[[VAL_12]](%[[VAL_17]]) {fortran_attrs = #fir.var_attrs, uniq_name = "_QQro[[name]]"} : (!fir.ref>, !fir.shapeshift<2>) -> (!fir.box>, !fir.ref>) +! CHECK: %[[VAL_16:.*]] = arith.constant 2 : index +! CHECK: %[[VAL_17:.*]] = fir.shape_shift %[[VAL_13]], %[[VAL_14]], %[[VAL_15]], %[[VAL_16]] : (index, index, index, index) -> !fir.shapeshift<2> +! CHECK: hlfir.declare %[[VAL_12]](%[[VAL_17]]) {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_constant_with_lower_boundsECi"} : (!fir.ref>, !fir.shapeshift<2>) -> (!fir.box>, !fir.ref>) end subroutine diff --git a/flang/test/Semantics/associate02.f90 b/flang/test/Semantics/associate02.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/associate02.f90 @@ -0,0 +1,78 @@ +! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s +! Sometimes associations with named constants involving non-default +! lower bounds expose those bounds to LBOUND()/UBOUND(), sometimes +! they do not. +subroutine s(n) + integer, intent(in) :: n + type t + real component(0:1,2:3) + end type + real, parameter :: abcd(2,2) = reshape([1.,2.,3.,4.], shape(abcd)) + real, parameter :: namedConst1(-1:0,-2:-1) = abcd + type(t), parameter :: namedConst2 = t(abcd) + type(t), parameter :: namedConst3(2:3,3:4) = reshape([(namedConst2,j=1,size(namedConst3))], shape(namedConst3)) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(abcd), ubound(abcd), shape(abcd) +!CHECK: PRINT *, [INTEGER(4)::-1_4,-2_4], [INTEGER(4)::0_4,-1_4], [INTEGER(4)::2_4,2_4] + print *, lbound(namedConst1), ubound(namedConst1), shape(namedConst1) +!CHECK: PRINT *, [INTEGER(4)::0_4,2_4], [INTEGER(4)::1_4,3_4], [INTEGER(4)::2_4,2_4] + print *, lbound(namedConst2%component), ubound(namedConst2%component), shape(namedConst2%component) +!CHECK: PRINT *, [INTEGER(4)::2_4,3_4], [INTEGER(4)::3_4,4_4], [INTEGER(4)::2_4,2_4] + print *, lbound(namedConst3), ubound(namedConst3), shape(namedConst3) +!CHECK: PRINT *, [INTEGER(4)::0_4,2_4], [INTEGER(4)::1_4,3_4], [INTEGER(4)::2_4,2_4] + print *, lbound(namedConst3(n,n)%component), ubound(namedConst3(n,n)%component), shape(namedConst3(n,n)%component) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(namedConst3%component(0,2)), ubound(namedConst3%component(0,2)), shape(namedConst3%component(0,2)) + associate (a => abcd) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => namedConst1) +!CHECK: PRINT *, [INTEGER(4)::-1_4,-2_4], [INTEGER(4)::0_4,-1_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => (namedConst1)) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => namedConst1 * 2.) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => namedConst2%component) +!CHECK: PRINT *, [INTEGER(4)::0_4,2_4], [INTEGER(4)::1_4,3_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => (namedConst2%component)) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => namedConst2%component * 2.) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => namedConst3) +!CHECK: PRINT *, [INTEGER(4)::2_4,3_4], [INTEGER(4)::3_4,4_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => (namedConst3)) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => namedConst3(n,n)%component) +!CHECK: PRINT *, [INTEGER(4)::0_4,2_4], [INTEGER(4)::1_4,3_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => (namedConst3(n,n)%component)) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => namedConst3(n,n)%component * 2.) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate + associate (a => namedConst3%component(0,2)) +!CHECK: PRINT *, [INTEGER(4)::1_4,1_4], [INTEGER(4)::2_4,2_4], [INTEGER(4)::2_4,2_4] + print *, lbound(a), ubound(a), shape(a) + end associate +end