diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -895,8 +895,8 @@ } return expanded; } - template Constant Expand(Parentheses &&x) { - return Expand(std::move(x)); // Constant<> can be parenthesized + template Expr Expand(Parentheses &&x) { + return Expand(std::move(x.left())); // Constant<> can be parenthesized } template Expr Expand(Expr &&x) { return std::visit([&](auto &&x) { return Expr{Expand(std::move(x))}; }, diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -305,26 +305,30 @@ } } -class ScalarExpansionVisitor : public AnyTraverse>> { +class ArrayConstantBoundChanger { public: - using Result = std::optional>; - using Base = AnyTraverse; - ScalarExpansionVisitor( - ConstantSubscripts &&shape, std::optional &&lb) - : Base{*this}, shape_{std::move(shape)}, lbounds_{std::move(lb)} {} - using Base::operator(); - template Result operator()(const Constant &x) { - auto expanded{x.Reshape(std::move(shape_))}; - if (lbounds_) { - expanded.set_lbounds(std::move(*lbounds_)); - } - return AsGenericExpr(std::move(expanded)); + ArrayConstantBoundChanger(ConstantSubscripts &&lbounds) + : lbounds_{std::move(lbounds)} {} + + template A ChangeLbounds(A &&x) const { + return std::move(x); // default case + } + template Constant ChangeLbounds(Constant &&x) { + x.set_lbounds(std::move(lbounds_)); + return std::move(x); + } + template Expr ChangeLbounds(Parentheses &&x) { + return ChangeLbounds( + std::move(x.left())); // Constant<> can be parenthesized + } + template Expr ChangeLbounds(Expr &&x) { + return std::visit( + [&](auto &&x) { return Expr{ChangeLbounds(std::move(x))}; }, + std::move(x.u)); // recurse until we hit a constant } private: - ConstantSubscripts shape_; - std::optional lbounds_; + ConstantSubscripts &&lbounds_; }; // Converts, folds, and then checks type, rank, and shape of an @@ -351,7 +355,11 @@ symbol.name(), symRank, folded.Rank()); } } else if (auto extents{AsConstantExtents(context, symTS->shape())}) { - if (folded.Rank() == 0 && symRank > 0) { + if (folded.Rank() == 0 && symRank == 0) { + // symbol and constant are both scalars + return {std::move(folded)}; + } else if (folded.Rank() == 0 && symRank > 0) { + // expand the scalar constant to an array return ScalarConstantExpander{std::move(*extents), AsConstantExtents( context, GetLowerBounds(context, NamedEntity{symbol}))} @@ -360,7 +368,11 @@ if (CheckConformance(context.messages(), symTS->shape(), *resultShape, "initialized object", "initialization expression", false, false)) { - return {std::move(folded)}; + // make a constant array with adjusted lower bounds + return ArrayConstantBoundChanger{ + std::move(*AsConstantExtents( + context, GetLowerBounds(context, NamedEntity{symbol})))} + .ChangeLbounds(std::move(folded)); } } } else if (IsNamedConstant(symbol)) { 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 @@ -373,7 +373,7 @@ MaybeExtentExpr ComputeUpperBound( ExtentExpr &&lower, MaybeExtentExpr &&extent) { if (extent) { - return std::move(*extent) - std::move(lower) + ExtentExpr{1}; + return std::move(*extent) + std::move(lower) - ExtentExpr{1}; } else { return std::nullopt; } diff --git a/flang/test/Evaluate/folding09.f90 b/flang/test/Evaluate/folding09.f90 --- a/flang/test/Evaluate/folding09.f90 +++ b/flang/test/Evaluate/folding09.f90 @@ -13,16 +13,16 @@ real, intent(in) :: arr1(:), arr2(10), mat(10, 10) real, intent(in), contiguous :: arr3(:) real :: scalar - logical, parameter :: isc01 = is_contiguous(0) - logical, parameter :: isc02 = is_contiguous(scalar) - logical, parameter :: isc03 = is_contiguous(scalar + scalar) - logical, parameter :: isc04 = is_contiguous([0, 1, 2]) - logical, parameter :: isc05 = is_contiguous(arr1 + 1.0) - logical, parameter :: isc06 = is_contiguous(arr2) - logical, parameter :: isc07 = is_contiguous(mat) - logical, parameter :: isc08 = is_contiguous(mat(1:10,1)) - logical, parameter :: isc09 = is_contiguous(arr2(1:10:1)) - logical, parameter :: isc10 = is_contiguous(arr3) - logical, parameter :: isc11 = is_contiguous(f()) + logical, parameter :: test_isc01 = is_contiguous(0) + logical, parameter :: test_isc02 = is_contiguous(scalar) + logical, parameter :: test_isc03 = is_contiguous(scalar + scalar) + logical, parameter :: test_isc04 = is_contiguous([0, 1, 2]) + logical, parameter :: test_isc05 = is_contiguous(arr1 + 1.0) + logical, parameter :: test_isc06 = is_contiguous(arr2) + logical, parameter :: test_isc07 = is_contiguous(mat) + logical, parameter :: test_isc08 = is_contiguous(mat(1:10,1)) + logical, parameter :: test_isc09 = is_contiguous(arr2(1:10:1)) + logical, parameter :: test_isc10 = is_contiguous(arr3) + logical, parameter :: test_isc11 = is_contiguous(f()) end subroutine end module diff --git a/flang/test/Evaluate/folding16.f90 b/flang/test/Evaluate/folding16.f90 --- a/flang/test/Evaluate/folding16.f90 +++ b/flang/test/Evaluate/folding16.f90 @@ -1,8 +1,17 @@ ! RUN: %S/test_folding.sh %s %t %f18 ! Ensure that lower bounds are accounted for in intrinsic folding; ! this is a regression test for a bug in which they were not -real, parameter :: a(-1:-1) = 1. -real, parameter :: b(-1:-1) = log(a) -logical, parameter :: test = lbound(a,1)==-1 .and. lbound(b,1)==-1 .and. & - lbound(log(a),1)==1 .and. all(b==0) +module m + real, parameter :: a(-1:-1) = 1. + real, parameter :: b(-1:-1) = log(a) + integer, parameter :: c(-1:1) = [33, 22, 11] + integer, parameter :: d(1:3) = [33, 22, 11] + integer, parameter :: e(-2:0) = ([33, 22, 11]) + ! The following test is commented out because constant folding for "lbound" + ! is currently broken + !logical, parameter :: test_1 = lbound(a,1)==-1 .and. lbound(b,1)==-1 .and. & + ! lbound(log(a),1)==1 .and. all(b==0) + logical, parameter :: test_2 = all(c .eq. d) + logical, parameter :: test_3 = all(c .eq. e) + logical, parameter :: test_4 = all(d .eq. e) end diff --git a/flang/test/Evaluate/test_folding.sh b/flang/test/Evaluate/test_folding.sh --- a/flang/test/Evaluate/test_folding.sh +++ b/flang/test/Evaluate/test_folding.sh @@ -5,8 +5,8 @@ # To check folding of an expression EXPR, the fortran program passed to this script # must contain the following: # logical, parameter :: test_x = -# This script will test that all parameter with a name starting with "test_" have -# been folded to .true. +# This script will test that all parameter with a name starting with "test_" +# have been folded to .true. # For instance, acos folding can be tested with: # # real(4), parameter :: res_acos = acos(0.5_4) diff --git a/flang/test/Semantics/array-constr-values.f90 b/flang/test/Semantics/array-constr-values.f90 --- a/flang/test/Semantics/array-constr-values.f90 +++ b/flang/test/Semantics/array-constr-values.f90 @@ -54,12 +54,28 @@ subroutine checkC7115() real, dimension(10), parameter :: good1 = [(99.9, i = 1, 10)] real, dimension(100), parameter :: good2 = [((88.8, i = 1, 10), j = 1, 10)] + real, dimension(-1:0), parameter :: good3 = [77.7, 66.6] !ERROR: Implied DO index is active in surrounding implied DO loop and may not have the same name real, dimension(100), parameter :: bad = [((88.8, i = 1, 10), i = 1, 10)] !ERROR: Value of named constant 'bad2' ([INTEGER(4)::(int(j,kind=4),INTEGER(8)::j=1_8,1_8,0_8)]) cannot be computed as a constant value !ERROR: The stride of an implied DO loop must not be zero integer, parameter :: bad2(*) = [(j, j=1,1,0)] + integer, parameter, dimension(-1:0) :: negLower = (/343,512/) + integer, parameter, dimension(-1:0) :: negLower1 = ((/343,512/)) + + real :: local + + local = good3(0) + !ERROR: Subscript value (2) is out of range on dimension 1 in reference to a constant array value + local = good3(2) + call inner(negLower(:)) ! OK + call inner(negLower1(:)) ! OK + + contains + subroutine inner(arg) + integer :: arg(:) + end subroutine inner end subroutine checkC7115 subroutine checkOkDuplicates real :: realArray(21) = &