[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

Author: klausler

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

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()) {

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;

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