diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h --- a/flang/include/flang/Semantics/symbol.h +++ b/flang/include/flang/Semantics/symbol.h @@ -271,6 +271,8 @@ } } + const Symbol *GetFinalForRank(int) const; + private: // These are (1) the names of the derived type parameters in the order // in which they appear on the type definition statement(s), and (2) the diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp --- a/flang/lib/Semantics/check-declarations.cpp +++ b/flang/lib/Semantics/check-declarations.cpp @@ -85,6 +85,7 @@ void CheckBlockData(const Scope &); void CheckGenericOps(const Scope &); bool CheckConflicting(const Symbol &, Attr, Attr); + void WarnMissingFinal(const Symbol &); bool InPure() const { return innermostSymbol_ && IsPureProcedure(*innermostSymbol_); } @@ -412,6 +413,7 @@ Check(details.shape()); Check(details.coshape()); CheckAssumedTypeEntity(symbol, details); + WarnMissingFinal(symbol); if (!details.coshape().empty()) { bool isDeferredShape{details.coshape().IsDeferredShape()}; if (IsAllocatable(symbol)) { @@ -1242,6 +1244,38 @@ } } +void CheckHelper::WarnMissingFinal(const Symbol &symbol) { + const auto *object{symbol.detailsIf()}; + if (!object || IsPointer(symbol)) { + return; + } + const DeclTypeSpec *type{object->type()}; + const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr}; + const Symbol *derivedSym{derived ? &derived->typeSymbol() : nullptr}; + int rank{object->shape().Rank()}; + const Symbol *initialDerivedSym{derivedSym}; + while (const auto *derivedDetails{ + derivedSym ? derivedSym->detailsIf() : nullptr}) { + if (!derivedDetails->finals().empty() && + !derivedDetails->GetFinalForRank(rank)) { + if (auto *msg{derivedSym == initialDerivedSym + ? messages_.Say(symbol.name(), + "'%s' of derived type '%s' does not have a FINAL subroutine for its rank (%d)"_en_US, + symbol.name(), derivedSym->name(), rank) + : messages_.Say(symbol.name(), + "'%s' of derived type '%s' extended from '%s' does not have a FINAL subroutine for its rank (%d)"_en_US, + symbol.name(), initialDerivedSym->name(), + derivedSym->name(), rank)}) { + msg->Attach(derivedSym->name(), + "Declaration of derived type '%s'"_en_US, derivedSym->name()); + } + return; + } + derived = derivedSym->GetParentTypeSpec(); + derivedSym = derived ? &derived->typeSymbol() : nullptr; + } +} + const Procedure *CheckHelper::Characterize(const Symbol &symbol) { auto it{characterizeCache_.find(symbol)}; if (it == characterizeCache_.end()) { diff --git a/flang/lib/Semantics/symbol.cpp b/flang/lib/Semantics/symbol.cpp --- a/flang/lib/Semantics/symbol.cpp +++ b/flang/lib/Semantics/symbol.cpp @@ -565,6 +565,25 @@ return nullptr; } +const Symbol *DerivedTypeDetails::GetFinalForRank(int rank) const { + for (const auto &pair : finals_) { + const Symbol &symbol{*pair.second}; + if (const auto *details{symbol.detailsIf()}) { + if (details->dummyArgs().size() == 1) { + if (const Symbol * arg{details->dummyArgs().at(0)}) { + if (const auto *object{arg->detailsIf()}) { + if (rank == object->shape().Rank() || object->IsAssumedRank() || + symbol.attrs().test(Attr::ELEMENTAL)) { + return &symbol; + } + } + } + } + } + } + return nullptr; +} + void TypeParamDetails::set_type(const DeclTypeSpec &type) { CHECK(!type_); type_ = &type; diff --git a/flang/test/Semantics/final02.f90 b/flang/test/Semantics/final02.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/final02.f90 @@ -0,0 +1,69 @@ +!RUN: %f18 -fparse-only %s 2>&1 | FileCheck %s +module m + type :: t1 + integer :: n + contains + final :: t1f0, t1f1 + end type + type :: t2 + integer :: n + contains + final :: t2fe + end type + type :: t3 + integer :: n + contains + final :: t3far + end type + type, extends(t1) :: t4 + end type + type :: t5 + !CHECK-NOT: 'scalar' of derived type 't1' + type(t1) :: scalar + !CHECK-NOT: 'vector' of derived type 't1' + type(t1) :: vector(2) + !CHECK: 'matrix' of derived type 't1' does not have a FINAL subroutine for its rank (2) + type(t1) :: matrix(2, 2) + end type + contains + subroutine t1f0(x) + type(t1) :: x + end subroutine + subroutine t1f1(x) + type(t1) :: x(:) + end subroutine + impure elemental subroutine t2fe(x) + type(t2) :: x + end subroutine + impure elemental subroutine t3far(x) + type(t3) :: x(..) + end subroutine +end module + +subroutine test ! *not* a main program, since they don't finalize locals + use m + !CHECK-NOT: 'scalar1' of derived type 't1' + type(t1) :: scalar1 + !CHECK-NOT: 'vector1' of derived type 't1' + type(t1) :: vector1(2) + !CHECK: 'matrix1' of derived type 't1' does not have a FINAL subroutine for its rank (2) + type(t1) :: matrix1(2,2) + !CHECK-NOT: 'scalar2' of derived type 't2' + type(t2) :: scalar2 + !CHECK-NOT: 'vector2' of derived type 't2' + type(t2) :: vector2(2) + !CHECK-NOT: 'matrix2' of derived type 't2' + type(t2) :: matrix2(2,2) + !CHECK-NOT: 'scalar3' of derived type 't3' + type(t3) :: scalar3 + !CHECK-NOT: 'vector3' of derived type 't3' + type(t3) :: vector3(2) + !CHECK-NOT: 'matrix3' of derived type 't2' + type(t3) :: matrix3(2,2) + !CHECK-NOT: 'scalar4' of derived type 't4' + type(t4) :: scalar4 + !CHECK-NOT: 'vector4' of derived type 't4' + type(t4) :: vector4(2) + !CHECK: 'matrix4' of derived type 't4' extended from 't1' does not have a FINAL subroutine for its rank (2) + type(t4) :: matrix4(2,2) +end