const Scope &scope, DefinabilityFlags flags,
const evaluate::Expr<evaluate::SomeType> &expr) {
if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
- if (!flags.test(DefinabilityFlag::VectorSubscriptIsOk) &&
- evaluate::HasVectorSubscript(expr)) {
- return parser::Message{at,
- "Variable '%s' has a vector subscript"_because_en_US,
- expr.AsFortran()};
+ if (evaluate::HasVectorSubscript(expr)) {
+ if (flags.test(DefinabilityFlag::VectorSubscriptIsOk)) {
+ if (auto type{expr.GetType()}) {
+ if (!type->IsUnlimitedPolymorphic() &&
+ type->category() == TypeCategory::Derived) {
+ // Seek the FINAL subroutine that should but cannot be called
+ // for this definition of an array with a vector-valued subscript.
+ // If there's an elemental FINAL subroutine, all is well; otherwise,
+ // if there is a FINAL subroutine with a matching or assumed rank
+ // dummy argument, there's no way to call it.
+ int rank{expr.Rank()};
+ const DerivedTypeSpec *spec{&type->GetDerivedTypeSpec()};
+ while (spec) {
+ bool anyElemental{false};
+ const Symbol *anyRankMatch{nullptr};
+ for (const auto &[_, ref] :
+ spec->typeSymbol().get<DerivedTypeDetails>().finals()) {
+ const Symbol &ultimate{ref->GetUltimate()};
+ anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL);
+ if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
+ if (!subp->dummyArgs().empty()) {
+ if (const Symbol * arg{subp->dummyArgs()[0]}) {
+ const auto *object{arg->detailsIf<ObjectEntityDetails>()};
+ if (arg->Rank() == rank ||
+ (object && object->IsAssumedRank())) {
+ anyRankMatch = &*ref;
+ }
+ }
+ }
+ }
+ }
+ if (anyRankMatch && !anyElemental) {
+ return parser::Message{at,
+ "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;
+ }
+ }
+ }
+ } else {
+ return parser::Message{at,
+ "Variable '%s' has a vector subscript"_because_en_US,
+ expr.AsFortran()};
+ }
}
if (FindPureProcedureContaining(scope) &&
evaluate::ExtractCoarrayRef(expr)) {
--- /dev/null
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+! Ensure that FINAL subroutine can be called for array with vector-valued
+! subscript.
+
+module m
+ type t1
+ contains
+ final :: f1
+ end type
+ type t2
+ contains
+ final :: f2
+ end type
+ type t3
+ contains
+ final :: f3
+ end type
+ contains
+ subroutine f1(x)
+ type(t1), intent(in out) :: x(:)
+ end subroutine
+ subroutine f2(x)
+ type(t2), intent(in out) :: x(..)
+ end subroutine
+ impure elemental subroutine f3(x)
+ type(t3), intent(in out) :: x
+ end subroutine
+end module
+
+program test
+ use m
+ type(t1) x1(1)
+ type(t2) x2(1)
+ type(t3) x3(1)
+ x1(:) = [t1()] ! ok
+ x2(:) = [t2()] ! ok
+ x3(:) = [t3()] ! ok
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Variable 'x1([INTEGER(8)::1_8])' has a vector subscript and cannot be finalized by non-elemental subroutine 'f1'
+ x1([1]) = [t1()]
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Variable 'x2([INTEGER(8)::1_8])' has a vector subscript and cannot be finalized by non-elemental subroutine 'f2'
+ x2([1]) = [t2()]
+ x3([1]) = [t3()] ! ok
+end