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 @@ -34,6 +34,15 @@ extern template bool IsConstantExpr(const Expr &); extern template bool IsConstantExpr(const StructureConstructor &); +// Predicate: true when an expression is a constant expression (in the +// strict sense of the Fortran standard) or a dummy argument with +// INTENT(IN) and no VALUE. This is useful for representing explicit +// shapes of other dummy arguments. +template bool IsScopeInvariantExpr(const A &); +extern template bool IsScopeInvariantExpr(const Expr &); +extern template bool IsScopeInvariantExpr(const Expr &); +extern template bool IsScopeInvariantExpr(const Expr &); + // Predicate: true when an expression actually is a typed Constant, // perhaps with parentheses and wrapping around it. False for all typeless // expressions, including BOZ literals. 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 @@ -18,13 +18,18 @@ namespace Fortran::evaluate { -// Constant expression predicate IsConstantExpr(). +// Constant expression predicates IsConstantExpr() & IsScopeInvariantExpr(). // This code determines whether an expression is a "constant expression" // in the sense of section 10.1.12. This is not the same thing as being // able to fold it (yet) into a known constant value; specifically, // the expression may reference derived type kind parameters whose values // are not yet known. -class IsConstantExprHelper : public AllTraverse { +// +// The variant form (IsScopeInvariantExpr()) also accepts symbols that are +// INTENT(IN) dummy arguments without the VALUE attribute. +template +class IsConstantExprHelper + : public AllTraverse, true> { public: using Base = AllTraverse; IsConstantExprHelper() : Base{*this} {} @@ -36,12 +41,15 @@ } bool operator()(const TypeParamInquiry &inq) const { - return semantics::IsKindTypeParameter(inq.parameter()); + return INVARIANT || semantics::IsKindTypeParameter(inq.parameter()); } bool operator()(const semantics::Symbol &symbol) const { const auto &ultimate{GetAssociationRoot(symbol)}; return IsNamedConstant(ultimate) || IsImpliedDoIndex(ultimate) || - IsInitialProcedureTarget(ultimate); + IsInitialProcedureTarget(ultimate) || + ultimate.has() || + (INVARIANT && IsIntentIn(symbol) && + !symbol.attrs().test(semantics::Attr::VALUE)); } bool operator()(const CoarrayRef &) const { return false; } bool operator()(const semantics::ParamValue ¶m) const { @@ -72,7 +80,12 @@ } bool operator()(const Constant &) const { return true; } - bool operator()(const DescriptorInquiry &) const { return false; } + bool operator()(const DescriptorInquiry &x) const { + const Symbol &sym{x.base().GetLastSymbol()}; + return INVARIANT && !IsAllocatable(sym) && + (!IsDummy(sym) || + (IsIntentIn(sym) && !sym.attrs().test(semantics::Attr::VALUE))); + } private: bool IsConstantStructureConstructorComponent( @@ -80,7 +93,8 @@ bool IsConstantExprShape(const Shape &) const; }; -bool IsConstantExprHelper::IsConstantStructureConstructorComponent( +template +bool IsConstantExprHelper::IsConstantStructureConstructorComponent( const Symbol &component, const Expr &expr) const { if (IsAllocatable(component)) { return IsNullPointer(expr); @@ -92,7 +106,9 @@ } } -bool IsConstantExprHelper::operator()(const ProcedureRef &call) const { +template +bool IsConstantExprHelper::operator()( + const ProcedureRef &call) const { // LBOUND, UBOUND, and SIZE with DIM= arguments will have been rewritten // into DescriptorInquiry operations. if (const auto *intrinsic{std::get_if(&call.proc().u)}) { @@ -122,7 +138,9 @@ return false; } -bool IsConstantExprHelper::IsConstantExprShape(const Shape &shape) const { +template +bool IsConstantExprHelper::IsConstantExprShape( + const Shape &shape) const { for (const auto &extent : shape) { if (!(*this)(extent)) { return false; @@ -132,13 +150,21 @@ } template bool IsConstantExpr(const A &x) { - return IsConstantExprHelper{}(x); + return IsConstantExprHelper{}(x); } template bool IsConstantExpr(const Expr &); template bool IsConstantExpr(const Expr &); template bool IsConstantExpr(const Expr &); template bool IsConstantExpr(const StructureConstructor &); +// IsScopeInvariantExpr() +template bool IsScopeInvariantExpr(const A &x) { + return IsConstantExprHelper{}(x); +} +template bool IsScopeInvariantExpr(const Expr &); +template bool IsScopeInvariantExpr(const Expr &); +template bool IsScopeInvariantExpr(const Expr &); + // IsActuallyConstant() struct IsActuallyConstantHelper { template bool operator()(const A &) { return false; } 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 @@ -10,6 +10,7 @@ #include "flang/Common/idioms.h" #include "flang/Common/template.h" #include "flang/Evaluate/characteristics.h" +#include "flang/Evaluate/check-expression.h" #include "flang/Evaluate/fold.h" #include "flang/Evaluate/intrinsics.h" #include "flang/Evaluate/tools.h" @@ -249,7 +250,8 @@ int j{0}; for (const auto &shapeSpec : details->shape()) { if (j++ == dimension_) { - if (const auto &bound{shapeSpec.lbound().GetExplicit()}) { + const auto &bound{shapeSpec.lbound().GetExplicit()}; + if (bound && IsScopeInvariantExpr(*bound)) { return *bound; } else if (IsDescriptor(symbol)) { return ExtentExpr{DescriptorInquiry{NamedEntity{symbol0}, @@ -282,7 +284,8 @@ int j{0}; for (const auto &shapeSpec : details->shape()) { if (j++ == dimension_) { - if (const auto &bound{shapeSpec.lbound().GetExplicit()}) { + const auto &bound{shapeSpec.lbound().GetExplicit()}; + if (bound && IsScopeInvariantExpr(*bound)) { return *bound; } else if (IsDescriptor(symbol)) { return ExtentExpr{ @@ -340,9 +343,21 @@ } else { return ExtentExpr{*uval - *lval + 1}; } + } else if (lbound && ubound && IsScopeInvariantExpr(*lbound) && + IsScopeInvariantExpr(*ubound)) { + // Apply effective IDIM (MAX calculation with 0) so thet the + // result is never negative + if (lval.value_or(0) == 1) { + return ExtentExpr{Extremum{ + Ordering::Greater, ExtentExpr{0}, common::Clone(*ubound)}}; + } else { + return ExtentExpr{ + Extremum{Ordering::Greater, ExtentExpr{0}, + common::Clone(*ubound) - common::Clone(*lbound) + ExtentExpr{1}}}; + } + } else { + return std::nullopt; } - return common::Clone(ubound.value()) - common::Clone(lbound.value()) + - ExtentExpr{1}; } MaybeExtentExpr GetExtent(const NamedEntity &base, int dimension) { @@ -372,21 +387,15 @@ int j{0}; for (const auto &shapeSpec : details->shape()) { if (j++ == dimension) { - if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) { - if (shapeSpec.ubound().GetExplicit()) { - // 8.5.8.2, paragraph 3. If the upper bound is less than the - // lower bound, the extent is zero. - if (shapeSpec.lbound().GetExplicit()) { - return GetNonNegativeExtent(shapeSpec); - } else { - return ubound.value(); - } - } + if (auto extent{GetNonNegativeExtent(shapeSpec)}) { + return extent; } else if (details->IsAssumedSize() && j == symbol.Rank()) { return std::nullopt; } else if (semantics::IsDescriptor(symbol)) { return ExtentExpr{DescriptorInquiry{NamedEntity{base}, DescriptorInquiry::Field::Extent, dimension}}; + } else { + break; } } } @@ -437,7 +446,11 @@ MaybeExtentExpr ComputeUpperBound( ExtentExpr &&lower, MaybeExtentExpr &&extent) { if (extent) { - return std::move(*extent) + std::move(lower) - ExtentExpr{1}; + if (ToInt64(lower).value_or(0) == 1) { + return std::move(*extent); + } else { + return std::move(*extent) + std::move(lower) - ExtentExpr{1}; + } } else { return std::nullopt; } @@ -454,7 +467,8 @@ int j{0}; for (const auto &shapeSpec : details->shape()) { if (j++ == dimension) { - if (const auto &bound{shapeSpec.ubound().GetExplicit()}) { + const auto &bound{shapeSpec.ubound().GetExplicit()}; + if (bound && IsScopeInvariantExpr(*bound)) { return *bound; } else if (details->IsAssumedSize() && dimension + 1 == symbol.Rank()) { break; @@ -487,10 +501,10 @@ Shape result; int dim{0}; for (const auto &shapeSpec : details->shape()) { - if (const auto &bound{shapeSpec.ubound().GetExplicit()}) { + const auto &bound{shapeSpec.ubound().GetExplicit()}; + if (bound && IsScopeInvariantExpr(*bound)) { result.push_back(*bound); - } else if (details->IsAssumedSize()) { - CHECK(dim + 1 == base.Rank()); + } else if (details->IsAssumedSize() && dim + 1 == base.Rank()) { result.emplace_back(std::nullopt); // UBOUND folding replaces with -1 } else { result.emplace_back( diff --git a/flang/test/Semantics/modfile33.f90 b/flang/test/Semantics/modfile33.f90 --- a/flang/test/Semantics/modfile33.f90 +++ b/flang/test/Semantics/modfile33.f90 @@ -572,7 +572,7 @@ ! real(4) :: x ! real(4) :: y(1_8:4_8, 1_8:n) ! real(4) :: z(1_8:2_8, 1_8:2_8, 1_8:2_8) -! real(4) :: a(1_8:int(int(4_8*(n-1_8+1_8),kind=4),kind=8)) +! real(4) :: a(1_8:int(int(4_8*size(y,dim=2),kind=4),kind=8)) ! real(4) :: b(1_8:add(y, z)) ! end !end diff --git a/flang/test/Semantics/offsets01.f90 b/flang/test/Semantics/offsets01.f90 --- a/flang/test/Semantics/offsets01.f90 +++ b/flang/test/Semantics/offsets01.f90 @@ -38,14 +38,14 @@ ! Descriptors with length parameters subroutine s5(n) integer :: n - type :: t1(l) - integer, len :: l - real :: a(l) + type :: t1(n) + integer, len :: n + real :: a(n) end type - type :: t2(l1, l2) - integer, len :: l1 - integer, len :: l2 - real :: b(l1, l2) + type :: t2(n1, n2) + integer, len :: n1 + integer, len :: n2 + real :: b(n1, n2) end type type(t1(n)) :: x1 !CHECK: x1 size=40 offset= type(t2(n,n)) :: x2 !CHECK: x2 size=48 offset=