diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h index e679a001235490f..a498444b0dd2b1f 100644 --- a/flang/include/flang/Evaluate/shape.h +++ b/flang/include/flang/Evaluate/shape.h @@ -183,8 +183,12 @@ class GetShapeHelper } template Result operator()(const Operation &operation) const { - if (operation.right().Rank() > 0) { - return (*this)(operation.right()); + if (int rr{operation.right().Rank()}; rr > 0) { + if (int lr{operation.left().Rank()}; lr == 0 || lr == rr) { + return (*this)(operation.right()); + } else { + return std::nullopt; + } } else { return (*this)(operation.left()); } diff --git a/flang/lib/Evaluate/fold-implementation.h b/flang/lib/Evaluate/fold-implementation.h index c82995c38f79f7e..208188a4ffcc770 100644 --- a/flang/lib/Evaluate/fold-implementation.h +++ b/flang/lib/Evaluate/fold-implementation.h @@ -1643,8 +1643,12 @@ auto ApplyElementwise(FoldingContext &context, -> std::optional> { auto resultLength{ComputeResultLength(operation)}; auto &leftExpr{operation.left()}; - leftExpr = Fold(context, std::move(leftExpr)); auto &rightExpr{operation.right()}; + if (leftExpr.Rank() != rightExpr.Rank() && leftExpr.Rank() != 0 && + rightExpr.Rank() != 0) { + return std::nullopt; // error recovery + } + leftExpr = Fold(context, std::move(leftExpr)); rightExpr = Fold(context, std::move(rightExpr)); if (leftExpr.Rank() > 0) { if (std::optional leftShape{GetShape(context, leftExpr)}) { diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp index f9d169e752cae5d..58b824d9b8e6441 100644 --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -254,7 +254,8 @@ class GetLowerBoundHelper if (dimension_ < rank) { const semantics::ShapeSpec &shapeSpec{object->shape()[dimension_]}; if (shapeSpec.lbound().isExplicit()) { - if (const auto &lbound{shapeSpec.lbound().GetExplicit()}) { + if (const auto &lbound{shapeSpec.lbound().GetExplicit()}; + lbound && lbound->Rank() == 0) { if constexpr (LBOUND_SEMANTICS) { bool ok{false}; auto lbValue{ToInt64(*lbound)}; @@ -266,7 +267,8 @@ class GetLowerBoundHelper } else if (lbValue.value_or(0) == 1) { // Lower bound is 1, regardless of extent ok = true; - } else if (const auto &ubound{shapeSpec.ubound().GetExplicit()}) { + } else if (const auto &ubound{shapeSpec.ubound().GetExplicit()}; + ubound && ubound->Rank() == 0) { // If we can't prove that the dimension is nonempty, // we must be conservative. // TODO: simple symbolic math in expression rewriting to @@ -459,7 +461,7 @@ static MaybeExtentExpr GetNonNegativeExtent( } else { return ExtentExpr{*uval - *lval + 1}; } - } else if (lbound && ubound && + } else if (lbound && ubound && lbound->Rank() == 0 && ubound->Rank() == 0 && (!invariantOnly || (IsScopeInvariantExpr(*lbound) && IsScopeInvariantExpr(*ubound)))) { // Apply effective IDIM (MAX calculation with 0) so thet the @@ -608,7 +610,8 @@ MaybeExtentExpr GetRawUpperBound( int rank{details->shape().Rank()}; if (dimension < rank) { const auto &bound{details->shape()[dimension].ubound().GetExplicit()}; - if (bound && (!invariantOnly || IsScopeInvariantExpr(*bound))) { + if (bound && bound->Rank() == 0 && + (!invariantOnly || IsScopeInvariantExpr(*bound))) { return *bound; } else if (semantics::IsAssumedSizeArray(symbol) && dimension + 1 == symbol.Rank()) { @@ -640,7 +643,8 @@ MaybeExtentExpr GetRawUpperBound(FoldingContext &context, static MaybeExtentExpr GetExplicitUBOUND(FoldingContext *context, const semantics::ShapeSpec &shapeSpec, bool invariantOnly) { const auto &ubound{shapeSpec.ubound().GetExplicit()}; - if (ubound && (!invariantOnly || IsScopeInvariantExpr(*ubound))) { + if (ubound && ubound->Rank() == 0 && + (!invariantOnly || IsScopeInvariantExpr(*ubound))) { if (auto extent{GetNonNegativeExtent(shapeSpec, invariantOnly)}) { if (auto cstExtent{ToInt64( context ? Fold(*context, std::move(*extent)) : *extent)}) { @@ -731,7 +735,8 @@ MaybeExtentExpr GetLCOBOUND( if (dimension < corank) { const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]}; if (const auto &lcobound{shapeSpec.lbound().GetExplicit()}) { - if (!invariantOnly || IsScopeInvariantExpr(*lcobound)) { + if (lcobound->Rank() == 0 && + (!invariantOnly || IsScopeInvariantExpr(*lcobound))) { return *lcobound; } } @@ -748,7 +753,8 @@ MaybeExtentExpr GetUCOBOUND( if (dimension < corank - 1) { const semantics::ShapeSpec &shapeSpec{object->coshape()[dimension]}; if (const auto ucobound{shapeSpec.ubound().GetExplicit()}) { - if (!invariantOnly || IsScopeInvariantExpr(*ucobound)) { + if (ucobound->Rank() == 0 && + (!invariantOnly || IsScopeInvariantExpr(*ucobound))) { return *ucobound; } } @@ -822,7 +828,7 @@ auto GetShapeHelper::operator()(const Symbol &symbol) const -> Result { if (subp.isFunction()) { auto resultShape{(*this)(subp.result())}; if (resultShape && !useResultSymbolShape_) { - // Ensure the shape is constant. Otherwise, it may be referring + // Ensure the shape is constant. Otherwise, it may be reerring // to symbols that belong to the function's scope and are // meaningless on the caller side without the related call // expression. @@ -908,23 +914,33 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result { if (auto chars{characteristics::Procedure::FromActuals( call.proc(), call.arguments(), *context_)}) { std::size_t j{0}; - std::size_t anyArrayArgRank{0}; + const ActualArgument *nonOptionalArrayArg{nullptr}; + int anyArrayArgRank{0}; for (const auto &arg : call.arguments()) { if (arg && arg->Rank() > 0 && j < chars->dummyArguments.size()) { - anyArrayArgRank = arg->Rank(); - if (!chars->dummyArguments[j].IsOptional()) { - return (*this)(*arg); + if (!anyArrayArgRank) { + anyArrayArgRank = arg->Rank(); + } else if (arg->Rank() != anyArrayArgRank) { + return std::nullopt; // error recovery + } + if (!nonOptionalArrayArg && + !chars->dummyArguments[j].IsOptional()) { + nonOptionalArrayArg = &*arg; } } ++j; } if (anyArrayArgRank) { - // All dummy array arguments of the procedure are OPTIONAL. - // We cannot take the shape from just any array argument, - // because all of them might be OPTIONAL dummy arguments - // of the caller. Return unknown shape ranked according - // to the last actual array argument. - return Shape(anyArrayArgRank, MaybeExtentExpr{}); + if (nonOptionalArrayArg) { + return (*this)(*nonOptionalArrayArg); + } else { + // All dummy array arguments of the procedure are OPTIONAL. + // We cannot take the shape from just any array argument, + // because all of them might be OPTIONAL dummy arguments + // of the caller. Return unknown shape ranked according + // to the last actual array argument. + return Shape(anyArrayArgRank, MaybeExtentExpr{}); + } } } } diff --git a/flang/test/Semantics/bug122002a.f90 b/flang/test/Semantics/bug122002a.f90 new file mode 100644 index 000000000000000..18fbed92a05f508 --- /dev/null +++ b/flang/test/Semantics/bug122002a.f90 @@ -0,0 +1,5 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! ERROR: Missing initialization for parameter 'n' +! ERROR: Must be a scalar value, but is a rank-1 array +integer, parameter :: n(n) +end diff --git a/flang/test/Semantics/bug122002b.f90 b/flang/test/Semantics/bug122002b.f90 new file mode 100644 index 000000000000000..1e4315d3afdb67d --- /dev/null +++ b/flang/test/Semantics/bug122002b.f90 @@ -0,0 +1,13 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +SUBROUTINE sub00(a,b,n,m) + complex(2) n,m +! ERROR: Must have INTEGER type, but is COMPLEX(2) +! ERROR: Must have INTEGER type, but is COMPLEX(2) +! ERROR: The type of 'b' has already been implicitly declared + complex(3) a(n,m), b(size((LOG ((x * (a) - a + b / a - a))+1 - x))) + a = a ** n +! ERROR: DO controls should be INTEGER + DO 10 j = 1,m + a = n ** a + 10 PRINT *, g +END SUBROUTINE sub00