diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h --- a/flang/include/flang/Evaluate/check-expression.h +++ b/flang/include/flang/Evaluate/check-expression.h @@ -50,6 +50,8 @@ extern template bool IsActuallyConstant(const Expr &); extern template bool IsActuallyConstant(const Expr &); extern template bool IsActuallyConstant(const Expr &); +extern template bool IsActuallyConstant( + const std::optional> &); // Checks whether an expression is an object designator with // constant addressing and no vector-valued subscript. 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 @@ -190,6 +190,7 @@ template bool IsActuallyConstant(const Expr &); template bool IsActuallyConstant(const Expr &); template bool IsActuallyConstant(const Expr &); +template bool IsActuallyConstant(const std::optional> &); // Object pointer initialization checking predicate IsInitialDataTarget(). // This code determines whether an expression is allowable as the static 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,17 @@ DescriptorInquiry::Field::LowerBound, dimension_}}; } } else { - return (*this)(assoc->expr()); + auto exprLowerBound{((*this)(assoc->expr()))}; + if (IsActuallyConstant(exprLowerBound)) { + return std::move(exprLowerBound); + } else { + // If the lower bound of the associated entity is not resolved to + // constant expression at the time of the association, it is unsafe + // to re-evaluate it later in the associate construct. Statements + // in-between may have modified its operands value. + return ExtentExpr{DescriptorInquiry{std::move(base), + DescriptorInquiry::Field::LowerBound, dimension_}}; + } } } if constexpr (LBOUND_SEMANTICS) { @@ -429,6 +439,26 @@ } } +MaybeExtentExpr GetAssociatedExtent(const NamedEntity &base, + const semantics::AssocEntityDetails &assoc, int dimension) { + if (auto shape{GetShape(assoc.expr())}) { + if (dimension < static_cast(shape->size())) { + auto &extent{shape->at(dimension)}; + if (extent && IsActuallyConstant(*extent)) { + return std::move(extent); + } else { + // Otherwise, evaluating the associated expression extent expression + // after the associate statement is unsafe given statements inside the + // associate may have modified the associated expression operands + // values. + return ExtentExpr{DescriptorInquiry{ + NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}}; + } + } + } + return std::nullopt; +} + MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) { CHECK(dimension >= 0); const Symbol &last{base.GetLastSymbol()}; @@ -439,10 +469,8 @@ return ExtentExpr{DescriptorInquiry{ NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}}; } - } else if (auto shape{GetShape(assoc->expr())}) { - if (dimension < static_cast(shape->size())) { - return std::move(shape->at(dimension)); - } + } else { + return GetAssociatedExtent(base, *assoc, dimension); } } if (const auto *details{symbol.detailsIf()}) { @@ -547,11 +575,9 @@ } } else if (const auto *assoc{ symbol.detailsIf()}) { - if (auto shape{GetShape(assoc->expr())}) { - if (dimension < static_cast(shape->size())) { - return ComputeUpperBound( - GetRawLowerBound(base, dimension), std::move(shape->at(dimension))); - } + if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) { + return ComputeUpperBound( + GetRawLowerBound(base, dimension), std::move(extent)); } } return std::nullopt; @@ -597,12 +623,9 @@ } } else if (const auto *assoc{ symbol.detailsIf()}) { - if (auto shape{GetShape(assoc->expr())}) { - if (dimension < static_cast(shape->size())) { - if (auto lb{GetLBOUND(base, dimension)}) { - return ComputeUpperBound( - std::move(*lb), std::move(shape->at(dimension))); - } + if (auto extent{GetAssociatedExtent(base, *assoc, dimension)}) { + if (auto lb{GetLBOUND(base, dimension)}) { + return ComputeUpperBound(std::move(*lb), std::move(extent)); } } } @@ -674,12 +697,22 @@ } }, [&](const semantics::AssocEntityDetails &assoc) { + NamedEntity base{symbol}; if (assoc.rank()) { // SELECT RANK case int n{assoc.rank().value()}; - NamedEntity base{symbol}; return Result{CreateShape(n, base)}; } else { - return (*this)(assoc.expr()); + auto exprShape{((*this)(assoc.expr()))}; + if (exprShape) { + int rank{static_cast(exprShape->size())}; + for (int dimension{0}; dimension < rank; ++dimension) { + auto &extent{(*exprShape)[dimension]}; + if (extent && !IsActuallyConstant(*extent)) { + extent = GetExtent(base, dimension); + } + } + } + return exprShape; } }, [&](const semantics::SubprogramDetails &subp) -> Result { diff --git a/flang/test/Evaluate/rewrite01.f90 b/flang/test/Evaluate/rewrite01.f90 --- a/flang/test/Evaluate/rewrite01.f90 +++ b/flang/test/Evaluate/rewrite01.f90 @@ -157,4 +157,33 @@ print *, len(mofun(m+1)) end subroutine len_test +!CHECK-LABEL: associate_tests +subroutine associate_tests(p) + real, pointer :: p(:) + real :: a(10:20) + interface + subroutine may_change_p_bounds(p) + real, pointer :: p(:) + end subroutine + end interface + associate(x => p) + call may_change_p_bounds(p) + !CHECK: PRINT *, lbound(x,dim=1,kind=8), size(x,dim=1,kind=8)+lbound(x,dim=1,kind=8)-1_8, size(x,dim=1,kind=8) + print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8) + end associate + associate(x => p+1) + call may_change_p_bounds(p) + !CHECK: PRINT *, 1_8, size(x,dim=1,kind=8), size(x,dim=1,kind=8) + print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8) + end associate + associate(x => a) + !CHECK: PRINT *, 10_8, 20_8, 11_8 + print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8) + end associate + associate(x => a+42.) + !CHECK: PRINT *, 1_8, 11_8, 11_8 + print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8) + end associate +end subroutine + end module