diff --git a/flang/include/flang/Evaluate/fold.h b/flang/include/flang/Evaluate/fold.h --- a/flang/include/flang/Evaluate/fold.h +++ b/flang/include/flang/Evaluate/fold.h @@ -92,6 +92,7 @@ std::optional ToInt64(const Expr &); std::optional ToInt64(const Expr &); +std::optional ToInt64(const ActualArgument &); template std::optional ToInt64(const std::optional &x) { @@ -102,12 +103,13 @@ } } -template std::optional ToInt64(const A *p) { +template std::optional ToInt64(A *p) { if (p) { - return ToInt64(*p); + return ToInt64(std::as_const(*p)); } else { return std::nullopt; } } + } // namespace Fortran::evaluate #endif // FORTRAN_EVALUATE_FOLD_H_ 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 @@ -312,15 +312,15 @@ } template std::optional ExtractDataRef( - const A *p, bool intoSubstring = false, bool intoComplexPart = false) { + A *p, bool intoSubstring = false, bool intoComplexPart = false) { if (p) { - return ExtractDataRef(*p, intoSubstring, intoComplexPart); + return ExtractDataRef(std::as_const(*p), intoSubstring, intoComplexPart); } else { return std::nullopt; } } -std::optional ExtractDataRef( - const ActualArgument &, bool intoSubstring = false); +std::optional ExtractDataRef(const ActualArgument &, + bool intoSubstring = false, bool intoComplexPart = false); std::optional ExtractSubstringBase(const Substring &); 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 @@ -533,7 +533,6 @@ context, std::move(funcRef), func, std::index_sequence_for{}); } -std::optional GetInt64Arg(const std::optional &); std::optional GetInt64ArgOr( const std::optional &, std::int64_t defaultValue); @@ -900,8 +899,8 @@ auto args{funcRef.arguments()}; CHECK(args.size() == 3); const Constant *source{UnwrapConstantValue(args[0])}; - auto dim{GetInt64Arg(args[1])}; - auto ncopies{GetInt64Arg(args[2])}; + auto dim{ToInt64(args[1])}; + auto ncopies{ToInt64(args[2])}; if (!source || !dim) { return Expr{std::move(funcRef)}; } 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 @@ -119,7 +119,7 @@ std::optional dim; if (funcRef.Rank() == 0) { // Optional DIM= argument is present: result is scalar. - if (auto dim64{GetInt64Arg(args[1])}) { + if (auto dim64{ToInt64(args[1])}) { if (*dim64 < 1 || *dim64 > rank) { context.messages().Say("DIM=%jd dimension is out of range for " "rank-%d array"_err_en_US, @@ -173,7 +173,7 @@ std::optional dim; if (funcRef.Rank() == 0) { // Optional DIM= argument is present: result is scalar. - if (auto dim64{GetInt64Arg(args[1])}) { + if (auto dim64{ToInt64(args[1])}) { if (*dim64 < 1 || *dim64 > rank) { context.messages().Say("DIM=%jd dimension is out of range for " "rank-%d array"_err_en_US, @@ -1014,7 +1014,7 @@ } } } else if (name == "selected_int_kind") { - if (auto p{GetInt64Arg(args[0])}) { + if (auto p{ToInt64(args[0])}) { return Expr{context.targetCharacteristics().SelectedIntKind(*p)}; } } else if (name == "selected_real_kind" || @@ -1073,7 +1073,7 @@ } else if (name == "size") { if (auto shape{GetContextFreeShape(context, args[0])}) { if (auto &dimArg{args[1]}) { // DIM= is present, get one extent - if (auto dim{GetInt64Arg(args[1])}) { + if (auto dim{ToInt64(args[1])}) { int rank{GetRank(*shape)}; if (*dim >= 1 && *dim <= rank) { const Symbol *symbol{UnwrapWholeSymbolDataRef(args[0])}; @@ -1190,11 +1190,11 @@ } std::optional ToInt64(const Expr &expr) { - if (const auto *intExpr{UnwrapExpr>(expr)}) { - return ToInt64(*intExpr); - } else { - return std::nullopt; - } + return ToInt64(UnwrapExpr>(expr)); +} + +std::optional ToInt64(const ActualArgument &arg) { + return ToInt64(arg.UnwrapExpr()); } #ifdef _MSC_VER // disable bogus warning about missing definitions diff --git a/flang/lib/Evaluate/fold.cpp b/flang/lib/Evaluate/fold.cpp --- a/flang/lib/Evaluate/fold.cpp +++ b/flang/lib/Evaluate/fold.cpp @@ -205,24 +205,9 @@ FoldOperation(context, std::move(complex)), complexPart.part()}; } -std::optional GetInt64Arg( - const std::optional &arg) { - if (const auto *intExpr{UnwrapExpr>(arg)}) { - return ToInt64(*intExpr); - } else { - return std::nullopt; - } -} - std::optional GetInt64ArgOr( const std::optional &arg, std::int64_t defaultValue) { - if (!arg) { - return defaultValue; - } else if (const auto *intExpr{UnwrapExpr>(arg)}) { - return ToInt64(*intExpr); - } else { - return std::nullopt; - } + return arg ? ToInt64(*arg) : defaultValue; } Expr FoldOperation( diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -1624,7 +1624,7 @@ const ActualArgument *operandArg{nullptr}; const IntrinsicDummyArgument *kindDummyArg{nullptr}; const ActualArgument *kindArg{nullptr}; - bool hasDimArg{false}; + std::optional dimArg; for (std::size_t j{0}; j < dummies; ++j) { const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; if (d.typePattern.kindCode == KindCode::kindArg) { @@ -1655,7 +1655,8 @@ } else { continue; } - } else if (d.optionality == Optionality::missing) { + } + if (d.optionality == Optionality::missing) { messages.Say(arg->sourceLocation(), "unexpected '%s=' argument"_err_en_US, d.keyword); return std::nullopt; @@ -1764,7 +1765,7 @@ break; case KindCode::dimArg: CHECK(type->category() == TypeCategory::Integer); - hasDimArg = true; + dimArg = j; argOk = true; break; case KindCode::same: @@ -1854,7 +1855,7 @@ int elementalRank{0}; for (std::size_t j{0}; j < dummies; ++j) { const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]}; - if (const ActualArgument * arg{actualForDummy[j]}) { + if (const ActualArgument *arg{actualForDummy[j]}) { bool isAssumedRank{IsAssumedRank(*arg)}; if (isAssumedRank && d.rank != Rank::anyOrAssumedRank) { messages.Say(arg->sourceLocation(), @@ -1934,7 +1935,7 @@ argOk = rank == knownArg->Rank(); break; case Rank::anyOrAssumedRank: - if (!hasDimArg && rank > 0 && !isAssumedRank && + if (!dimArg && rank > 0 && !isAssumedRank && (std::strcmp(name, "shape") == 0 || std::strcmp(name, "size") == 0 || std::strcmp(name, "ubound") == 0)) { @@ -2141,6 +2142,49 @@ CHECK(result.kindCode == KindCode::none); } + // Emit warnings when the syntactic presence of a DIM= argument determines + // the semantics of the call but the associated actual argument may not be + // present at execution time. + if (dimArg) { + std::optional arrayRank; + if (arrayArg) { + arrayRank = arrayArg->Rank(); + if (auto dimVal{ToInt64(actualForDummy[*dimArg])}) { + if (*dimVal < 1) { + messages.Say( + "The value of DIM= (%jd) may not be less than 1"_err_en_US, + static_cast(*dimVal)); + } else if (*dimVal > *arrayRank) { + messages.Say( + "The value of DIM= (%jd) may not be greater than %d"_err_en_US, + static_cast(*dimVal), *arrayRank); + } + } + } + switch (rank) { + case Rank::dimReduced: + case Rank::dimRemovedOrScalar: + case Rank::locReduced: + case Rank::scalarIfDim: + if (dummy[*dimArg].optionality == Optionality::required) { + if (const Symbol *whole{ + UnwrapWholeSymbolOrComponentDataRef(actualForDummy[*dimArg])}) { + if (IsOptional(*whole) || IsAllocatableOrPointer(*whole)) { + if (rank == Rank::scalarIfDim || arrayRank.value_or(-1) == 1) { + messages.Say( + "The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time"_port_en_US); + } else { + messages.Say( + "The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning"_warn_en_US); + } + } + } + } + break; + default:; + } + } + // At this point, the call is acceptable. // Determine the rank of the function result. int resultRank{0}; @@ -2163,11 +2207,11 @@ break; case Rank::dimReduced: CHECK(arrayArg); - resultRank = hasDimArg ? arrayArg->Rank() - 1 : 0; + resultRank = dimArg ? arrayArg->Rank() - 1 : 0; break; case Rank::locReduced: CHECK(arrayArg); - resultRank = hasDimArg ? arrayArg->Rank() - 1 : 1; + resultRank = dimArg ? arrayArg->Rank() - 1 : 1; break; case Rank::rankPlus1: CHECK(knownArg); @@ -2178,7 +2222,7 @@ resultRank = *shapeArgSize; break; case Rank::scalarIfDim: - resultRank = hasDimArg ? 0 : 1; + resultRank = dimArg ? 0 : 1; break; case Rank::elementalOrBOZ: case Rank::shape: @@ -2197,7 +2241,7 @@ // Rearrange the actual arguments into dummy argument order. ActualArguments rearranged(dummies); for (std::size_t j{0}; j < dummies; ++j) { - if (ActualArgument * arg{actualForDummy[j]}) { + if (ActualArgument *arg{actualForDummy[j]}) { rearranged[j] = std::move(*arg); } } @@ -2602,7 +2646,7 @@ bool ok{true}; if (const auto &pointerArg{call.arguments[0]}) { if (const auto *pointerExpr{pointerArg->UnwrapExpr()}) { - if (const Symbol * pointerSymbol{GetLastSymbol(*pointerExpr)}) { + if (const Symbol *pointerSymbol{GetLastSymbol(*pointerExpr)}) { if (!pointerSymbol->attrs().test(semantics::Attr::POINTER)) { AttachDeclaration(context.messages().Say(pointerArg->sourceLocation(), "POINTER= argument of ASSOCIATED() must be a " @@ -2896,7 +2940,7 @@ ok &= CheckForCoindexedObject(context, call.arguments[3], name, "errmsg"); if (call.arguments[0] && call.arguments[1]) { for (int j{0}; j < 2; ++j) { - if (const Symbol * last{GetLastSymbol(call.arguments[j])}; + if (const Symbol *last{GetLastSymbol(call.arguments[j])}; last && !IsAllocatable(last->GetUltimate())) { context.messages().Say(call.arguments[j]->sourceLocation(), "Argument #%d to MOVE_ALLOC must be allocatable"_err_en_US, @@ -2916,7 +2960,7 @@ const auto &arg{call.arguments[0]}; if (arg) { if (const auto *expr{arg->UnwrapExpr()}) { - if (const Symbol * symbol{UnwrapWholeSymbolDataRef(*expr)}) { + if (const Symbol *symbol{UnwrapWholeSymbolDataRef(*expr)}) { ok = symbol->attrs().test(semantics::Attr::OPTIONAL); } } diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -60,12 +60,8 @@ } std::optional ExtractDataRef( - const ActualArgument &arg, bool intoSubstring) { - if (const Expr *expr{arg.UnwrapExpr()}) { - return ExtractDataRef(*expr, intoSubstring); - } else { - return std::nullopt; - } + const ActualArgument &arg, bool intoSubstring, bool intoComplexPart) { + return ExtractDataRef(arg.UnwrapExpr(), intoSubstring, intoComplexPart); } std::optional ExtractSubstringBase(const Substring &substring) { diff --git a/flang/test/Lower/transformational-intrinsics.f90 b/flang/test/Lower/transformational-intrinsics.f90 --- a/flang/test/Lower/transformational-intrinsics.f90 +++ b/flang/test/Lower/transformational-intrinsics.f90 @@ -141,7 +141,7 @@ ! CHECK: %[[VAL_14:.*]] = fir.alloca !fir.array<6xi32> {bindc_name = "vectorresult", uniq_name = "_QMtest2Fcshift_testEvectorresult"} ! CHECK: %[[VAL_15:.*]] = fir.shape %[[VAL_6]], %[[VAL_7]] : (index, index) -> !fir.shape<2> ! CHECK: %[[VAL_16:.*]] = fir.array_load %[[VAL_8]](%[[VAL_15]]) : (!fir.ref>, !fir.shape<2>) -> !fir.array<3x3xi32> - ! CHECK: %[[VAL_17:.*]] = arith.constant -2 : i32 + ! CHECK: %[[VAL_17:.*]] = arith.constant 2 : i32 ! CHECK: %[[VAL_18:.*]] = fir.shape %[[VAL_3]], %[[VAL_4]] : (index, index) -> !fir.shape<2> ! CHECK: %[[VAL_19:.*]] = fir.embox %[[VAL_5]](%[[VAL_18]]) : (!fir.ref>, !fir.shape<2>) -> !fir.box> ! CHECK: %[[VAL_20:.*]] = fir.zero_bits !fir.heap> @@ -224,7 +224,7 @@ integer, dimension(3, 3) :: result integer, dimension(6) :: vectorResult integer, dimension (6) :: vector - result = cshift(array, shift, -2) ! non-vector case + result = cshift(array, shift, 2) ! non-vector case vectorResult = cshift(vector, 3) ! vector case end subroutine cshift_test diff --git a/flang/test/Semantics/dim01.f90 b/flang/test/Semantics/dim01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/dim01.f90 @@ -0,0 +1,68 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +! Test warnings and errors about DIM= arguments to transformational intrinsics + +module m + contains + function f0a(a) + real, intent(in) :: a(:) + !ERROR: The value of DIM= (-1) may not be less than 1 + f0a = sum(a,dim=-1) + end function + function f0b(a) + real, intent(in) :: a(:) + !ERROR: The value of DIM= (2) may not be greater than 1 + f0b = sum(a,dim=2) + end function + function f1(a,d) + real, intent(in) :: a(:) + integer, optional, intent(in) :: d + !PORTABILITY: The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time + f1 = sum(a,dim=d) + end function + function f2(a,d) + real, intent(in) :: a(:) + integer, pointer, intent(in) :: d + !PORTABILITY: The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time + f2 = sum(a,dim=d) + end function + function f3(a,d) + real, intent(in) :: a(:) + integer, allocatable, intent(in) :: d + !PORTABILITY: The actual argument for DIM= is optional, pointer, or allocatable, and it is assumed to be present and equal to 1 at execution time + f3 = sum(a,dim=d) + end function + function f10a(a) + real, intent(in) :: a(:,:) + real, allocatable :: f10a(:) + !ERROR: The value of DIM= (-1) may not be less than 1 + f10a = sum(a,dim=-1) + end function + function f10b(a) + real, intent(in) :: a(:,:) + real, allocatable :: f10b(:) + !ERROR: The value of DIM= (3) may not be greater than 2 + f10b = sum(a,dim=3) + end function + function f11(a,d) + real, intent(in) :: a(:,:) + integer, optional, intent(in) :: d + real, allocatable :: f11(:) + !WARNING: The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning + f11 = sum(a,dim=d) + end function + function f12(a,d) + real, intent(in) :: a(:,:) + integer, pointer, intent(in) :: d + real, allocatable :: f12(:) + !WARNING: The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning + f12 = sum(a,dim=d) + end function + function f13(a,d) + real, intent(in) :: a(:,:) + integer, allocatable, intent(in) :: d + real, allocatable :: f13(:) + !WARNING: The actual argument for DIM= is optional, pointer, or allocatable, and may not be absent during execution; parenthesize to silence this warning + f13 = sum(a,dim=d) + end function +end module +