[flang] Add warning for FINAL pitfall

[klausler]

Summary

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.

[PeteSteinfeld]

All builds, tests, and looks good.

flang/include/flang/Semantics/symbol.h

public:
   std::optional<SourceName> GetParentComponentName() const {
     if (componentNames_.empty()) {
       return std::nullopt;
     } else {
       return componentNames_.front();
     }
   }
 
+  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
   // symbols that correspond to those names in the order in which their
   // declarations appear in the derived type definition(s).
   std::list<SourceName> paramNames_;
   SymbolVector paramDecls_;
   // These are the names of the derived type's components in component

flang/lib/Semantics/check-declarations.cpp

bool CheckDefinedOperatorArg(
       const SourceName &, const Symbol &, const Procedure &, std::size_t);
   bool CheckDefinedAssignment(const Symbol &, const Procedure &);
   bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);
   void CheckSpecificsAreDistinguishable(const Symbol &, const GenericDetails &);
   void CheckEquivalenceSet(const EquivalenceSet &);
   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_);
   }
   bool InFunction() const {
     return innermostSymbol_ && IsFunction(*innermostSymbol_);
   }
   template <typename... A>
   void SayWithDeclaration(const Symbol &symbol, A &&...x) {

 }
 
 void CheckHelper::CheckObjectEntity(
     const Symbol &symbol, const ObjectEntityDetails &details) {
   CheckArraySpec(symbol, details.shape());
   Check(details.shape());
   Check(details.coshape());
   CheckAssumedTypeEntity(symbol, details);
+  WarnMissingFinal(symbol);
   if (!details.coshape().empty()) {
     bool isDeferredShape{details.coshape().IsDeferredShape()};
     if (IsAllocatable(symbol)) {
       if (!isDeferredShape) { // C827
         messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"
                       " coshape"_err_en_US,
             symbol.name());
       }
if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
     messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
         symbol.name(), EnumToString(a1), EnumToString(a2));
     return true;
   } else {
     return false;
   }
 }
 
+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()) {
     auto pair{characterizeCache_.emplace(SymbolRef{symbol},
         Procedure::Characterize(symbol, context_.intrinsics()))};
     it = pair.first;
   }
   return common::GetPtrFromOptional(it->second);

flang/lib/Semantics/symbol.cpp

if (auto iter{scope.find(*extends)}; iter != scope.cend()) {
           symbol.test(Symbol::Flag::ParentComp)) {
         return &symbol;
       }
     }
   }
   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;
 }
 
 bool GenericKind::IsIntrinsicOperator() const {
   return Is(OtherKind::Concat) || Has<common::LogicalOperator>() ||
       Has<common::NumericOperator>() || Has<common::RelationalOperator>();

flang/test/Semantics/final02.f90

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