[flang-commits] [flang] c116867 - [flang] Add warning for FINAL pitfall
peter klausler via flang-commits
flang-commits at lists.llvm.org
Fri Oct 30 16:42:27 PDT 2020
Author: peter klausler
Date: 2020-10-30T16:42:12-07:00
New Revision: c1168676a0c211641cbd5945eb46702fc50e56de
URL: https://github.com/llvm/llvm-project/commit/c1168676a0c211641cbd5945eb46702fc50e56de
DIFF: https://github.com/llvm/llvm-project/commit/c1168676a0c211641cbd5945eb46702fc50e56de.diff
LOG: [flang] Add warning for FINAL pitfall
Fortran's FINAL feature is sensitive to object rank.
When an object's rank excludes it from finalization, but
the type has FINAL subroutines for other ranks, emit
a warning. This should be especially helpful in the
case of a scalar FINAL subroutine not being declared
(IMPURE) ELEMENTAL.
Differential revision: https://reviews.llvm.org/D90495
Added:
flang/test/Semantics/final02.f90
Modified:
flang/include/flang/Semantics/symbol.h
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/symbol.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index ca6ab22c14ca..5ac32ac59b16 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -271,6 +271,8 @@ class DerivedTypeDetails {
}
}
+ 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
index 6138297c273b..a0b445b8d046 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -85,6 +85,7 @@ class CheckHelper {
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 @@ void CheckHelper::CheckObjectEntity(
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 @@ bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
}
}
+void CheckHelper::WarnMissingFinal(const Symbol &symbol) {
+ const auto *object{symbol.detailsIf<ObjectEntityDetails>()};
+ 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<DerivedTypeDetails>() : 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
index 06c4ac4275a0..93c2ac3b163d 100644
--- a/flang/lib/Semantics/symbol.cpp
+++ b/flang/lib/Semantics/symbol.cpp
@@ -565,6 +565,25 @@ const Symbol *DerivedTypeDetails::GetParentComponent(const Scope &scope) const {
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<SubprogramDetails>()}) {
+ if (details->dummyArgs().size() == 1) {
+ if (const Symbol * arg{details->dummyArgs().at(0)}) {
+ if (const auto *object{arg->detailsIf<ObjectEntityDetails>()}) {
+ 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
index 000000000000..b58f91f3a228
--- /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
More information about the flang-commits
mailing list