diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -448,6 +448,7 @@ } // Definability + bool actualIsVariable{evaluate::IsVariable(actual)}; const char *reason{nullptr}; if (dummy.intent == common::Intent::Out) { reason = "INTENT(OUT)"; @@ -457,7 +458,7 @@ if (reason && scope) { // Problems with polymorphism are caught in the callee's definition. DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure}; - if (isElemental || dummyIsValue) { // 15.5.2.4(21) + if (isElemental) { // 15.5.2.4(21) flags.set(DefinabilityFlag::VectorSubscriptIsOk); } if (actualIsPointer && dummyIsPointer) { // 19.6.8 @@ -475,7 +476,6 @@ // technically legal but worth emitting a warning // llvm-project issue #58973: constant actual argument passed in where dummy // argument is marked volatile - bool actualIsVariable{evaluate::IsVariable(actual)}; if (dummyIsVolatile && !actualIsVariable && context.ShouldWarn(common::UsageWarning::ExprPassedToVolatile)) { messages.Say( diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h --- a/flang/lib/Semantics/definable.h +++ b/flang/lib/Semantics/definable.h @@ -27,6 +27,7 @@ ENUM_CLASS(DefinabilityFlag, VectorSubscriptIsOk, // a vector subscript may appear (i.e., assignment) + DuplicatesAreOk, // vector subscript may have duplicates PointerDefinition, // a pointer is being defined, not its target AcceptAllocatable, // treat allocatable as if it were a pointer PolymorphicOkInPure) // don't check for polymorphic type in pure subprogram diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp --- a/flang/lib/Semantics/definable.cpp +++ b/flang/lib/Semantics/definable.cpp @@ -244,6 +244,47 @@ return WhyNotDefinableLast(at, scope, flags, original); } +class DuplicatedSubscriptFinder + : public evaluate::AnyTraverse { + using Base = evaluate::AnyTraverse; + +public: + explicit DuplicatedSubscriptFinder(evaluate::FoldingContext &foldingContext) + : Base{*this}, foldingContext_{foldingContext} {} + using Base::operator(); + bool operator()(const evaluate::ActualArgument &) { + return false; // don't descend into argument expressions + } + bool operator()(const evaluate::ArrayRef &aRef) { + bool anyVector{false}; + for (const auto &ss : aRef.subscript()) { + if (ss.Rank() > 0) { + anyVector = true; + if (const auto *vecExpr{ + std::get_if(&ss.u)}) { + auto folded{evaluate::Fold(foldingContext_, + evaluate::Expr{vecExpr->value()})}; + if (const auto *con{ + evaluate::UnwrapConstantValue( + folded)}) { + std::set values; + for (const auto &j : con->values()) { + if (auto pair{values.emplace(j.ToInt64())}; !pair.second) { + return true; // duplicate + } + } + } + return false; + } + } + } + return anyVector ? false : (*this)(aRef.base()); + } + +private: + evaluate::FoldingContext &foldingContext_; +}; + std::optional WhyNotDefinable(parser::CharBlock at, const Scope &scope, DefinabilityFlags flags, const evaluate::Expr &expr) { @@ -288,6 +329,11 @@ } } } + if (!flags.test(DefinabilityFlag::DuplicatesAreOk) && + DuplicatedSubscriptFinder{scope.context().foldingContext()}(expr)) { + return parser::Message{at, + "Variable has a vector subscript with a duplicated element"_because_en_US}; + } } else { return parser::Message{at, "Variable '%s' has a vector subscript"_because_en_US, diff --git a/flang/test/Semantics/definable06.f90 b/flang/test/Semantics/definable06.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/definable06.f90 @@ -0,0 +1,20 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +module m + contains + elemental subroutine inout(x) + integer, intent(inout) :: x + end + subroutine test + integer :: x(2) + !ERROR: Left-hand side of assignment is not definable + !BECAUSE: Variable has a vector subscript with a duplicated element + x([1,1]) = 0 + !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable + !BECAUSE: Variable has a vector subscript with a duplicated element + call inout(x([(mod(j-1,2)+1,j=1,10)])) + !ERROR: Input variable 'x' is not definable + !BECAUSE: Variable has a vector subscript with a duplicated element + read (*,*) x([2,2]) + end +end +