[flang] Emit errors on vector subscripts with duplicated elements when object must be definable

[klausler]

Summary

When the left-hand side of an assignment, or any other context demanding
definability, comprises a designator with a vector subscript that is
known at compilation time to have one or more duplicated elements,
emit an error message.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Semantics/check-call.cpp

if (actualLastObject && actualLastObject->IsCoarray() &&
           evaluate::AcceptsIntentOutAllocatableCoarray(
               intrinsic->name))) { // C846
     messages.Say(
         "ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
         actualLastSymbol->name(), dummyName);
   }
 
   // Definability
+  bool actualIsVariable{evaluate::IsVariable(actual)};
   const char *reason{nullptr};
   if (dummy.intent == common::Intent::Out) {
     reason = "INTENT(OUT)";
   } else if (dummy.intent == common::Intent::InOut) {
     reason = "INTENT(IN OUT)";
   }
   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
       flags.set(DefinabilityFlag::PointerDefinition);
     }
     if (auto whyNot{WhyNotDefinable(messages.at(), *scope, flags, actual)}) {
       if (auto *msg{messages.Say(
               "Actual argument associated with %s %s is not definable"_err_en_US,
               reason, dummyName)}) {
         msg->Attach(std::move(*whyNot));
       }
     }
   }
 
   // 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(
         "actual argument associated with VOLATILE %s is not a variable"_warn_en_US,
         dummyName);
   }
 
   // Cases when temporaries might be needed but must not be permitted.

flang/lib/Semantics/definable.h

 
 namespace Fortran::semantics {
 
 class Symbol;
 class Scope;
 
 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
 
 using DefinabilityFlags =
     common::EnumSet<DefinabilityFlag, DefinabilityFlag_enumSize>;
 
 // Tests a symbol or LHS variable or pointer for definability in a given scope.

flang/lib/Semantics/definable.cpp

 std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
   if (auto base{WhyNotDefinableBase(at, scope, flags, original)}) {
     return base;
   }
   return WhyNotDefinableLast(at, scope, flags, original);
 }
 
+class DuplicatedSubscriptFinder
+    : public evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool> {
+  using Base = evaluate::AnyTraverse<DuplicatedSubscriptFinder, bool>;
+
+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<evaluate::IndirectSubscriptIntegerExpr>(&ss.u)}) {
+          auto folded{evaluate::Fold(foldingContext_,
+              evaluate::Expr<evaluate::SubscriptInteger>{vecExpr->value()})};
+          if (const auto *con{
+                  evaluate::UnwrapConstantValue<evaluate::SubscriptInteger>(
+                      folded)}) {
+            std::set<std::int64_t> 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<parser::Message> WhyNotDefinable(parser::CharBlock at,
     const Scope &scope, DefinabilityFlags flags,
     const evaluate::Expr<evaluate::SomeType> &expr) {
   if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
     if (evaluate::HasVectorSubscript(expr)) {
       if (flags.test(DefinabilityFlag::VectorSubscriptIsOk)) {
         if (auto type{expr.GetType()}) {
           if (!type->IsUnlimitedPolymorphic() &&
if (evaluate::HasVectorSubscript(expr)) {
                     "Variable '%s' has a vector subscript and cannot be finalized by non-elemental subroutine '%s'"_because_en_US,
                     expr.AsFortran(), anyRankMatch->name()};
               }
               const auto *parent{FindParentTypeSpec(*spec)};
               spec = parent ? parent->AsDerived() : nullptr;
             }
           }
         }
+        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,
             expr.AsFortran()};
       }
     }
     if (FindPureProcedureContaining(scope) &&
         evaluate::ExtractCoarrayRef(expr)) {

flang/test/Semantics/definable06.f90

+! 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
+