[flang] Semantic analysis for FINAL subroutines

[klausler]

Summary

Represent FINAL subroutines in the symbol table entries of
derived types. Enforce constraints. Update tests that have
inadvertent violations or modified messages. Added a test.

The specific procedure distinguishability checking code for generics
was used to enforce distinguishability of FINAL procedures.
(Also cleaned up some confusion and redundancy noticed in the
type compatibility infrastructure while digging into that area.)

[tskeith]

flang/lib/Semantics/check-declarations.cpp

849

With clang 9 I get this error:

error: reference to local binding 'ref' declared in enclosing function 'Fortran::semantics::CheckHelper::CheckDerivedType'

And same for source.

[klausler]

flang/lib/Semantics/check-declarations.cpp

849

Thanks, I'll work around that and push an update shortly.

[klausler]

Worked around clang error noticed by code reviewer, & added
a "const" suggested by the clang-tidy bot.

[klausler]

Previous update to this review had inadvertent changes to other files because I neglected to rebase after updating master; now fixed. Sorry for the scare!

flang/include/flang/Evaluate/characteristics.h

 
 using common::CopyableIndirection;
 
-// Are these procedures distinguishable for a generic name?
+// Are these procedures distinguishable for a generic name or FINAL?
 bool Distinguishable(const Procedure &, const Procedure &);
 // Are these procedures distinguishable for a generic operator or assignment?
 bool DistinguishableOpOrAssign(const Procedure &, const Procedure &);

flang/include/flang/Evaluate/type.h

   bool HasDeferredTypeParameter() const;
 
   // 7.3.2.3 & 15.5.2.4 type compatibility.
-  // x.IsTypeCompatibleWith(y) is true if "x => y" or passing actual y to
+  // x.IsTkCompatibleWith(y) is true if "x => y" or passing actual y to
   // dummy argument x would be valid.  Be advised, this is not a reflexive
-  // relation.
-  bool IsTypeCompatibleWith(const DynamicType &) const;
-  // Type compatible and kind type parameters match
+  // relation.  Kind type parameters must match.
   bool IsTkCompatibleWith(const DynamicType &) const;
 
   // Result will be missing when a symbol is absent or

flang/include/flang/Semantics/symbol.h

   const std::list<SourceName> &paramNames() const { return paramNames_; }
   const SymbolVector &paramDecls() const { return paramDecls_; }
   bool sequence() const { return sequence_; }
+  std::map<SourceName, SymbolRef> &finals() { return finals_; }
+  const std::map<SourceName, SymbolRef> &finals() const { return finals_; }
   bool isForwardReferenced() const { return isForwardReferenced_; }
   void add_paramName(const SourceName &name) { paramNames_.push_back(name); }
   void add_paramDecl(const Symbol &symbol) { paramDecls_.push_back(symbol); }

   // These are the names of the derived type's components in component
   // order.  A parent component, if any, appears first in this list.
   std::list<SourceName> componentNames_;
+  std::map<SourceName, SymbolRef> finals_; // FINAL :: subr
   bool sequence_{false};
   bool isForwardReferenced_{false};
   friend llvm::raw_ostream &operator<<(

   std::size_t alignment_{0}; // required alignment in bytes
 };
 
-class FinalProcDetails {}; // TODO
-
 class MiscDetails {
 public:
   ENUM_CLASS(Kind, None, ConstructName, ScopeName, PassName, ComplexPartRe,

     ObjectEntityDetails, ProcEntityDetails, AssocEntityDetails,
     DerivedTypeDetails, UseDetails, UseErrorDetails, HostAssocDetails,
     GenericDetails, ProcBindingDetails, NamelistDetails, CommonBlockDetails,
-    FinalProcDetails, TypeParamDetails, MiscDetails>;
+    TypeParamDetails, MiscDetails>;
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const Details &);
 std::string DetailsToString(const Details &);
 

flang/include/flang/Semantics/tools.h

 }
 bool IsAssumedLengthCharacter(const Symbol &);
 bool IsExternal(const Symbol &);
+bool IsModuleProcedure(const Symbol &);
 // Is the symbol modifiable in this scope
 std::optional<parser::MessageFixedText> WhyNotModifiable(
     const Symbol &, const Scope &);

   return value && *value == 0;
 }
 
+// 15.2.2
+enum class ProcedureDefinitionClass {
+  None,
+  Intrinsic,
+  External,
+  Internal,
+  Module,
+  Dummy,
+  Pointer,
+  StatementFunction
+};
+
+ProcedureDefinitionClass ClassifyProcedure(const Symbol &);
+
 // Derived type component iterator that provides a C++ LegacyForwardIterator
 // iterator over the Ordered, Direct, Ultimate or Potential components of a
 // DerivedTypeSpec. These iterators can be used with STL algorithms

flang/lib/Evaluate/characteristics.cpp

     const TypeAndShape &that, const char *thisIs, const char *thatIs,
     bool isElemental) const {
   const auto &len{that.LEN()};
-  if (!type_.IsTypeCompatibleWith(that.type_)) {
+  if (!type_.IsTkCompatibleWith(that.type_)) {
     messages.Say(
         "%1$s type '%2$s' is not compatible with %3$s type '%4$s'"_err_en_US,
         thatIs, that.type_.AsFortran(len ? len->AsFortran() : ""), thisIs,

flang/lib/Evaluate/tools.cpp

           [](const GenericDetails &) { return true; },
           [](const ProcBindingDetails &) { return true; },
           [](const UseDetails &x) { return IsProcedure(x.symbol()); },
-          // TODO: FinalProcDetails?
           [](const auto &) { return false; },
       },
       symbol.details());

flang/lib/Evaluate/type.cpp

   }
 }
 
-static const semantics::Symbol *FindComponent(
-    const semantics::DerivedTypeSpec &derived, parser::CharBlock name) {
-  if (const auto *scope{derived.scope()}) {
-    auto iter{scope->find(name)};
-    if (iter != scope->end()) {
-      return &*iter->second;
-    } else if (const auto *parent{GetParentTypeSpec(derived)}) {
-      return FindComponent(*parent, name);
-    }
-  }
-  return nullptr;
-}
-
 // Compares two derived type representations to see whether they both
 // represent the "same type" in the sense of section 7.5.2.4.
 using SetOfDerivedTypePairs =

   if (x.attrs().test(semantics::Attr::PRIVATE)) {
     return false;
   }
-#if 0 // TODO
-  if (const auto *xObject{x.detailsIf<semantics::ObjectEntityDetails>()}) {
-    if (const auto *yObject{y.detailsIf<semantics::ObjectEntityDetails>()}) {
-#else
-  if (x.has<semantics::ObjectEntityDetails>()) {
-    if (y.has<semantics::ObjectEntityDetails>()) {
-#endif
-  // TODO: compare types, type parameters, bounds, &c.
-  return true;
-}
-else {
-  return false;
-}
-} // namespace Fortran::evaluate
-else {
-  // TODO: non-object components
-  return true;
-}
+  // TODO: compare types, parameters, bounds, &c.
+  return x.has<semantics::ObjectEntityDetails>() ==
+      y.has<semantics::ObjectEntityDetails>();
 }
 
 static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,

   return param && param->attr() == common::TypeParamAttr::Kind;
 }
 
-static bool IsKindTypeParameter(
-    const semantics::DerivedTypeSpec &derived, parser::CharBlock name) {
-  const semantics::Symbol *symbol{FindComponent(derived, name)};
-  return symbol && IsKindTypeParameter(*symbol);
-}
-
-bool DynamicType::IsTypeCompatibleWith(const DynamicType &that) const {
-  if (derived_) {
-    if (!AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic())) {
-      return false;
-    }
-    // The values of derived type KIND parameters must match.
-    for (const auto &[name, param] : derived_->parameters()) {
-      if (IsKindTypeParameter(*derived_, name)) {
-        bool ok{false};
-        if (auto myValue{ToInt64(param.GetExplicit())}) {
-          if (const auto *thatParam{that.derived_->FindParameter(name)}) {
-            if (auto thatValue{ToInt64(thatParam->GetExplicit())}) {
-              ok = *myValue == *thatValue;
-            }
-          }
-        }
-        if (!ok) {
-          return false;
-        }
-      }
-    }
-    return true;
-  } else if (category_ == that.category_ && kind_ == that.kind_) {
-    // CHARACTER length is not checked here
-    return true;
-  } else {
-    return IsUnlimitedPolymorphic();
-  }
-}
-
 // Do the kind type parameters of type1 have the same values as the
-// corresponding kind type parameters of the type2?
-static bool IsKindCompatible(const semantics::DerivedTypeSpec &type1,
+// corresponding kind type parameters of type2?
+static bool AreKindCompatible(const semantics::DerivedTypeSpec &type1,
     const semantics::DerivedTypeSpec &type2) {
   for (const auto &[name, param1] : type1.parameters()) {
     if (param1.isKind()) {

   return true;
 }
 
+// See 7.3.2.3 (5) & 15.5.2.4
 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
-  if (category_ != TypeCategory::Derived) {
-    return category_ == that.category_ && kind_ == that.kind_;
-  } else if (IsUnlimitedPolymorphic()) {
+  if (IsUnlimitedPolymorphic()) {
     return true;
   } else if (that.IsUnlimitedPolymorphic()) {
     return false;
-  } else if (!derived_ || !that.derived_ ||
-      !IsKindCompatible(*derived_, *that.derived_)) {
-    return false; // kind params don't match
+  } else if (category_ != that.category_) {
+    return false;
+  } else if (derived_) {
+    return that.derived_ &&
+        AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic()) &&
+        AreKindCompatible(*derived_, *that.derived_);
   } else {
-    return AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic());
+    return kind_ == that.kind_;
   }
 }
 

flang/lib/Semantics/check-call.cpp

   parser::ContextualMessages &messages{context.messages()};
   PadShortCharacterActual(actual, dummy.type, actualType, messages);
   ConvertIntegerActual(actual, dummy.type, actualType, messages);
-  bool typesCompatible{
-      dummy.type.type().IsTypeCompatibleWith(actualType.type())};
+  bool typesCompatible{dummy.type.type().IsTkCompatibleWith(actualType.type())};
   if (typesCompatible) {
     if (isElemental) {
     } else if (dummy.type.attrs().test(

             "Actual argument associated with TYPE(*) %s may not have type-bound procedure '%s'"_err_en_US,
             dummyName, tbp->name());
       }
-      if (const Symbol *
-          finalizer{FindImmediateComponent(*derived, [](const Symbol &symbol) {
-            return symbol.has<FinalProcDetails>();
-          })}) { // 15.5.2.4(2)
-        evaluate::SayWithDeclaration(messages, *finalizer,
-            "Actual argument associated with TYPE(*) %s may not have FINAL subroutine '%s'"_err_en_US,
-            dummyName, finalizer->name());
+      const auto &finals{
+          derived->typeSymbol().get<DerivedTypeDetails>().finals()};
+      if (!finals.empty()) { // 15.5.2.4(2)
+        if (auto *msg{messages.Say(
+                "Actual argument associated with TYPE(*) %s may not have derived type '%s' with FINAL subroutine '%s'"_err_en_US,
+                dummyName, derived->typeSymbol().name(),
+                finals.begin()->first)}) {
+          msg->Attach(finals.begin()->first,
+              "FINAL subroutine '%s' in derived type '%s'"_en_US,
+              finals.begin()->first, derived->typeSymbol().name());
+        }
       }
     }
     if (actualIsCoindexed) {

             "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both must be so"_err_en_US);
       }
     } else if (!actualIsUnlimited && typesCompatible) {
-      if (!actualType.type().IsTypeCompatibleWith(dummy.type.type())) {
+      if (!actualType.type().IsTkCompatibleWith(dummy.type.type())) {
         if (dummy.intent == common::Intent::In) {
           // extension: allow with warning, rule is only relevant for definables
           messages.Say(
-              "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type"_en_US);
+              "POINTER or ALLOCATABLE dummy and actual arguments should have the same declared type and kind"_en_US);
         } else {
           messages.Say(
-              "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type"_err_en_US);
+              "POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind"_err_en_US);
         }
       }
       if (const auto *derived{

flang/lib/Semantics/check-declarations.cpp

   void CheckSubprogram(const Symbol &, const SubprogramDetails &);
   void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &);
   void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
+  bool CheckFinal(
+      const Symbol &subroutine, SourceName, const Symbol &derivedType);
+  bool CheckDistinguishableFinals(const Symbol &f1, SourceName f1name,
+      const Symbol &f2, SourceName f2name, const Symbol &derivedType);
   void CheckGeneric(const Symbol &, const GenericDetails &);
   void CheckHostAssoc(const Symbol &, const HostAssocDetails &);
   bool CheckDefinedOperator(

 }
 
 void CheckHelper::CheckDerivedType(
-    const Symbol &symbol, const DerivedTypeDetails &details) {
-  const Scope *scope{symbol.scope()};
+    const Symbol &derivedType, const DerivedTypeDetails &details) {
+  const Scope *scope{derivedType.scope()};
   if (!scope) {
     CHECK(details.isForwardReferenced());
     return;
   }
-  CHECK(scope->symbol() == &symbol);
+  CHECK(scope->symbol() == &derivedType);
   CHECK(scope->IsDerivedType());
-  if (symbol.attrs().test(Attr::ABSTRACT) && // C734
-      (symbol.attrs().test(Attr::BIND_C) || details.sequence())) {
+  if (derivedType.attrs().test(Attr::ABSTRACT) && // C734
+      (derivedType.attrs().test(Attr::BIND_C) || details.sequence())) {
     messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
   }
-  if (const DeclTypeSpec * parent{FindParentTypeSpec(symbol)}) {
+  if (const DeclTypeSpec * parent{FindParentTypeSpec(derivedType)}) {
     const DerivedTypeSpec *parentDerived{parent->AsDerived()};
     if (!IsExtensibleType(parentDerived)) { // C705
       messages_.Say("The parent type is not extensible"_err_en_US);
     }
-    if (!symbol.attrs().test(Attr::ABSTRACT) && parentDerived &&
+    if (!derivedType.attrs().test(Attr::ABSTRACT) && parentDerived &&
         parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
       ScopeComponentIterator components{*parentDerived};
       for (const Symbol &component : components) {

         }
       }
     }
-    DerivedTypeSpec derived{symbol.name(), symbol};
+    DerivedTypeSpec derived{derivedType.name(), derivedType};
     derived.set_scope(*scope);
     if (FindCoarrayUltimateComponent(derived) && // C736
         !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {

           "Type '%s' has a coarray ultimate component so the type at the base "
           "of its type extension chain ('%s') must be a type that has a "
           "coarray ultimate component"_err_en_US,
-          symbol.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
+          derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
     }
     if (FindEventOrLockPotentialComponent(derived) && // C737
         !(FindEventOrLockPotentialComponent(*parentDerived) ||

           "at the base of its type extension chain ('%s') must either have an "
           "EVENT_TYPE or LOCK_TYPE component, or be EVENT_TYPE or "
           "LOCK_TYPE"_err_en_US,
-          symbol.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
+          derivedType.name(), scope->GetDerivedTypeBase().GetSymbol()->name());
     }
   }
-  if (HasIntrinsicTypeName(symbol)) { // C729
+  if (HasIntrinsicTypeName(derivedType)) { // C729
     messages_.Say("A derived type name cannot be the name of an intrinsic"
                   " type"_err_en_US);
   }
+  std::map<SourceName, SymbolRef> previous;
+  for (const auto &pair : details.finals()) {
+    SourceName source{pair.first};
+    const Symbol &ref{*pair.second};
+    if (CheckFinal(ref, source, derivedType) &&
+        std::all_of(previous.begin(), previous.end(),
+            [&](std::pair<SourceName, SymbolRef> prev) {
+              return CheckDistinguishableFinals(
+                  ref, source, *prev.second, prev.first, derivedType);
+            })) {
+      previous.emplace(source, ref);
+    }
+  }
+}
+
+// C786
+bool CheckHelper::CheckFinal(
+    const Symbol &subroutine, SourceName finalName, const Symbol &derivedType) {
+  if (!IsModuleProcedure(subroutine)) {
+    SayWithDeclaration(subroutine, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must be a module procedure"_err_en_US,
+        subroutine.name(), derivedType.name());
+    return false;
+  }
+  const Procedure *proc{Characterize(subroutine)};
+  if (!proc) {
+    return false; // error recovery
+  }
+  if (!proc->IsSubroutine()) {
+    SayWithDeclaration(subroutine, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must be a subroutine"_err_en_US,
+        subroutine.name(), derivedType.name());
+    return false;
+  }
+  if (proc->dummyArguments.size() != 1) {
+    SayWithDeclaration(subroutine, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument"_err_en_US,
+        subroutine.name(), derivedType.name());
+    return false;
+  }
+  const auto &arg{proc->dummyArguments[0]};
+  const Symbol *errSym{&subroutine};
+  if (const auto *details{subroutine.detailsIf<SubprogramDetails>()}) {
+    if (!details->dummyArgs().empty()) {
+      if (const Symbol * argSym{details->dummyArgs()[0]}) {
+        errSym = argSym;
+      }
+    }
+  }
+  const auto *ddo{std::get_if<DummyDataObject>(&arg.u)};
+  if (!ddo) {
+    SayWithDeclaration(subroutine, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must have a single dummy argument that is a data object"_err_en_US,
+        subroutine.name(), derivedType.name());
+    return false;
+  }
+  bool ok{true};
+  if (arg.IsOptional()) {
+    SayWithDeclaration(*errSym, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must not have an OPTIONAL dummy argument"_err_en_US,
+        subroutine.name(), derivedType.name());
+    ok = false;
+  }
+  if (ddo->attrs.test(DummyDataObject::Attr::Allocatable)) {
+    SayWithDeclaration(*errSym, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must not have an ALLOCATABLE dummy argument"_err_en_US,
+        subroutine.name(), derivedType.name());
+    ok = false;
+  }
+  if (ddo->attrs.test(DummyDataObject::Attr::Pointer)) {
+    SayWithDeclaration(*errSym, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must not have a POINTER dummy argument"_err_en_US,
+        subroutine.name(), derivedType.name());
+    ok = false;
+  }
+  if (ddo->intent == common::Intent::Out) {
+    SayWithDeclaration(*errSym, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with INTENT(OUT)"_err_en_US,
+        subroutine.name(), derivedType.name());
+    ok = false;
+  }
+  if (ddo->attrs.test(DummyDataObject::Attr::Value)) {
+    SayWithDeclaration(*errSym, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must not have a dummy argument with the VALUE attribute"_err_en_US,
+        subroutine.name(), derivedType.name());
+    ok = false;
+  }
+  if (ddo->type.corank() > 0) {
+    SayWithDeclaration(*errSym, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must not have a coarray dummy argument"_err_en_US,
+        subroutine.name(), derivedType.name());
+    ok = false;
+  }
+  if (ddo->type.type().IsPolymorphic()) {
+    SayWithDeclaration(*errSym, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must not have a polymorphic dummy argument"_err_en_US,
+        subroutine.name(), derivedType.name());
+    ok = false;
+  } else if (ddo->type.type().category() != TypeCategory::Derived ||
+      &ddo->type.type().GetDerivedTypeSpec().typeSymbol() != &derivedType) {
+    SayWithDeclaration(*errSym, finalName,
+        "FINAL subroutine '%s' of derived type '%s' must have a TYPE(%s) dummy argument"_err_en_US,
+        subroutine.name(), derivedType.name(), derivedType.name());
+    ok = false;
+  } else { // check that all LEN type parameters are assumed
+    for (auto ref : OrderParameterDeclarations(derivedType)) {
+      if (const auto *paramDetails{ref->detailsIf<TypeParamDetails>()}) {
+        if (paramDetails->attr() == common::TypeParamAttr::Len) {
+          const auto *value{
+              ddo->type.type().GetDerivedTypeSpec().FindParameter(ref->name())};
+          if (!value || !value->isAssumed()) {
+            SayWithDeclaration(*errSym, finalName,
+                "FINAL subroutine '%s' of derived type '%s' must have a dummy argument with an assumed LEN type parameter '%s=*'"_err_en_US,
+                subroutine.name(), derivedType.name(), ref->name());
+            ok = false;
+          }
+        }
+      }
+    }
+  }
+  return ok;
+}
+
+bool CheckHelper::CheckDistinguishableFinals(const Symbol &f1,
+    SourceName f1Name, const Symbol &f2, SourceName f2Name,
+    const Symbol &derivedType) {
+  const Procedure *p1{Characterize(f1)};
+  const Procedure *p2{Characterize(f2)};
+  if (p1 && p2) {
+    if (characteristics::Distinguishable(*p1, *p2)) {
+      return true;
+    }
+    if (auto *msg{messages_.Say(f1Name,
+            "FINAL subroutines '%s' and '%s' of derived type '%s' cannot be distinguished by rank or KIND type parameter value"_err_en_US,
+            f1Name, f2Name, derivedType.name())}) {
+      msg->Attach(f2Name, "FINAL declaration of '%s'"_en_US, f2.name())
+          .Attach(f1.name(), "Definition of '%s'"_en_US, f1Name)
+          .Attach(f2.name(), "Definition of '%s'"_en_US, f2Name);
+    }
+  }
+  return false;
 }
 
 void CheckHelper::CheckHostAssoc(

flang/lib/Semantics/mod-file.h

   void WriteOne(const Scope &);
   void Write(const Symbol &);
   std::string GetAsString(const Symbol &);
-  void PutSymbols(const Scope &);
+  // Returns true if a derived type with bindings and "contains" was emitted
+  bool PutSymbols(const Scope &);
   void PutSymbol(llvm::raw_ostream &, const Symbol &);
   void PutDerivedType(const Symbol &);
   void PutSubprogram(const Symbol &);

flang/lib/Semantics/mod-file.cpp

 }
 
 // Put out the visible symbols from scope.
-void ModFileWriter::PutSymbols(const Scope &scope) {
+bool ModFileWriter::PutSymbols(const Scope &scope) {
   std::string buf;
   llvm::raw_string_ostream typeBindings{
       buf}; // stuff after CONTAINS in derived type

   if (auto str{typeBindings.str()}; !str.empty()) {
     CHECK(scope.IsDerivedType());
     decls_ << "contains\n" << str;
+    return true;
+  } else {
+    return false;
   }
 }
 

                      decls_ << "::/" << symbol.name() << "/\n";
                    }
                  },
-                 [&](const FinalProcDetails &) {
-                   typeBindings << "final::" << symbol.name() << '\n';
-                 },
                  [](const HostAssocDetails &) {},
                  [](const MiscDetails &) {},
                  [&](const auto &) { PutEntity(decls_, symbol); },

   if (details.sequence()) {
     decls_ << "sequence\n";
   }
-  PutSymbols(typeScope);
+  bool contains{PutSymbols(typeScope)};
+  if (!details.finals().empty()) {
+    const char *sep{contains ? "final::" : "contains\nfinal::"};
+    for (const auto &pair : details.finals()) {
+      decls_ << sep << pair.second->name();
+      sep = ",";
+    }
+    if (*sep == ',') {
+      decls_ << '\n';
+    }
+  }
   decls_ << "end type\n";
 }
 

flang/lib/Semantics/pointer-assignment.cpp

               " derived type when target is unlimited polymorphic"_err_en_US;
       }
     } else {
-      if (!lhsType_->type().IsTypeCompatibleWith(rhsType->type())) {
+      if (!lhsType_->type().IsTkCompatibleWith(rhsType->type())) {
         msg = MessageFormattedText{
             "Target type %s is not compatible with pointer type %s"_err_en_US,
             rhsType->type().AsFortran(), lhsType_->type().AsFortran()};

flang/lib/Semantics/resolve-names.cpp

 }
 
 void DeclarationVisitor::Post(const parser::FinalProcedureStmt &x) {
-  for (auto &name : x.v) {
-    MakeTypeSymbol(name, FinalProcDetails{});
+  if (currScope().IsDerivedType() && currScope().symbol()) {
+    if (auto *details{currScope().symbol()->detailsIf<DerivedTypeDetails>()}) {
+      for (const auto &subrName : x.v) {
+        if (const auto *name{ResolveName(subrName)}) {
+          auto pair{
+              details->finals().emplace(name->source, DEREF(name->symbol))};
+          if (!pair.second) { // C787
+            Say(name->source,
+                "FINAL subroutine '%s' already appeared in this derived type"_err_en_US,
+                name->source)
+                .Attach(pair.first->first,
+                    "earlier appearance of this FINAL subroutine"_en_US);
+          }
+        }
+      }
+    }
   }
 }
 

flang/lib/Semantics/symbol.cpp

           [](const ProcBindingDetails &) { return "ProcBinding"; },
           [](const NamelistDetails &) { return "Namelist"; },
           [](const CommonBlockDetails &) { return "CommonBlockDetails"; },
-          [](const FinalProcDetails &) { return "FinalProc"; },
           [](const TypeParamDetails &) { return "TypeParam"; },
           [](const MiscDetails &) { return "Misc"; },
           [](const AssocEntityDetails &) { return "AssocEntity"; },

               os << ' ' << object->name();
             }
           },
-          [&](const FinalProcDetails &) {},
           [&](const TypeParamDetails &x) {
             DumpOptional(os, "type", x.type());
             os << ' ' << common::EnumToString(x.attr());

flang/lib/Semantics/tools.cpp

 }
 
 bool IsFinalizable(const DerivedTypeSpec &derived) {
-  ScopeComponentIterator components{derived};
-  return std::find_if(components.begin(), components.end(),
-             [](const Symbol &x) { return x.has<FinalProcDetails>(); }) !=
-      components.end();
+  if (!derived.typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
+    return true;
+  }
+  DirectComponentIterator components{derived};
+  return bool{std::find_if(components.begin(), components.end(),
+      [](const Symbol &component) { return IsFinalizable(component); })};
 }
 
-// TODO The following function returns true for all types with FINAL procedures
-// This is because we don't yet fill in the data for FinalProcDetails
 bool HasImpureFinal(const DerivedTypeSpec &derived) {
-  ScopeComponentIterator components{derived};
-  return std::find_if(
-             components.begin(), components.end(), [](const Symbol &x) {
-               return x.has<FinalProcDetails>() && !x.attrs().test(Attr::PURE);
-             }) != components.end();
+  if (const auto *details{
+          derived.typeSymbol().detailsIf<DerivedTypeDetails>()}) {
+    const auto &finals{details->finals()};
+    return std::any_of(finals.begin(), finals.end(),
+        [](const auto &x) { return !x.second->attrs().test(Attr::PURE); });
+  } else {
+    return false;
+  }
 }
 
 bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; }

 // C722 and C723:  For a function to be assumed length, it must be external and
 // of CHARACTER type
 bool IsExternal(const Symbol &symbol) {
-  return (symbol.has<SubprogramDetails>() && symbol.owner().IsGlobal()) ||
-      symbol.attrs().test(Attr::EXTERNAL);
+  return ClassifyProcedure(symbol) == ProcedureDefinitionClass::External;
 }
 
+bool IsModuleProcedure(const Symbol &symbol) {
+  return ClassifyProcedure(symbol) == ProcedureDefinitionClass::Module;
+}
 const Symbol *IsExternalInPureContext(
     const Symbol &symbol, const Scope &scope) {
   if (const auto *pureProc{FindPureProcedureContaining(scope)}) {

   return nullptr;
 }
 
+ProcedureDefinitionClass ClassifyProcedure(const Symbol &symbol) { // 15.2.2
+  const Symbol &ultimate{symbol.GetUltimate()};
+  if (ultimate.attrs().test(Attr::INTRINSIC)) {
+    return ProcedureDefinitionClass::Intrinsic;
+  } else if (ultimate.attrs().test(Attr::EXTERNAL)) {
+    return ProcedureDefinitionClass::External;
+  } else if (const auto *procDetails{ultimate.detailsIf<ProcEntityDetails>()}) {
+    if (procDetails->isDummy()) {
+      return ProcedureDefinitionClass::Dummy;
+    } else if (IsPointer(ultimate)) {
+      return ProcedureDefinitionClass::Pointer;
+    }
+  } else if (const Symbol * subp{FindSubprogram(symbol)}) {
+    if (const auto *subpDetails{subp->detailsIf<SubprogramDetails>()}) {
+      if (subpDetails->stmtFunction()) {
+        return ProcedureDefinitionClass::StatementFunction;
+      }
+    }
+    switch (ultimate.owner().kind()) {
+    case Scope::Kind::Global:
+      return ProcedureDefinitionClass::External;
+    case Scope::Kind::Module:
+      return ProcedureDefinitionClass::Module;
+    case Scope::Kind::MainProgram:
+    case Scope::Kind::Subprogram:
+      return ProcedureDefinitionClass::Internal;
+    default:
+      break;
+    }
+  }
+  return ProcedureDefinitionClass::None;
+}
+
 // ComponentIterator implementation
 
 template <ComponentKind componentKind>

flang/test/Semantics/call03.f90

     class(tbp), intent(in) :: this
   end subroutine
   subroutine subr02(this)
-    class(final), intent(in) :: this
+    type(final), intent(inout) :: this
   end subroutine
 
   subroutine poly(x)

 
   subroutine test05 ! 15.5.2.4(2)
     type(final) :: x
-    !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have FINAL subroutine 'subr02'
+    !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have derived type 'final' with FINAL subroutine 'subr02'
     call typestar(x)
   end subroutine
 

flang/test/Semantics/call05.f90

     call spp(up)
     !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't'
     call spa(ua)
-    !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type
+    !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
     call spp(pp2)
-    !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type
+    !ERROR: POINTER or ALLOCATABLE dummy and actual arguments must have the same declared type and kind
     call spa(pa2)
     !ERROR: Rank of dummy argument is 1, but actual argument has rank 2
     call smp(mpmat)

flang/test/Semantics/final01.f90

+! RUN: %S/test_errors.sh %s %t %f18
+! Test FINAL subroutine constraints C786-C789
+module m1
+  external :: external
+  intrinsic :: sin
+  real :: object
+  procedure(valid), pointer :: pointer
+  type :: parent(kind1, len1)
+    integer, kind :: kind1 = 1
+    integer, len :: len1 = 1
+  end type
+  type, extends(parent) :: child(kind2, len2)
+    integer, kind :: kind2 = 2
+    integer, len :: len2 = 2
+   contains
+    final :: valid
+!ERROR: FINAL subroutine 'external' of derived type 'child' must be a module procedure
+!ERROR: FINAL subroutine 'sin' of derived type 'child' must be a module procedure
+!ERROR: FINAL subroutine 'object' of derived type 'child' must be a module procedure
+!ERROR: FINAL subroutine 'pointer' of derived type 'child' must be a module procedure
+!ERROR: FINAL subroutine 'func' of derived type 'child' must be a subroutine
+    final :: external, sin, object, pointer, func
+!ERROR: FINAL subroutine 's01' of derived type 'child' must have a single dummy argument that is a data object
+!ERROR: FINAL subroutine 's02' of derived type 'child' must have a single dummy argument that is a data object
+!ERROR: FINAL subroutine 's03' of derived type 'child' must not have a dummy argument with INTENT(OUT)
+!ERROR: FINAL subroutine 's04' of derived type 'child' must not have a dummy argument with the VALUE attribute
+!ERROR: FINAL subroutine 's05' of derived type 'child' must not have a POINTER dummy argument
+!ERROR: FINAL subroutine 's06' of derived type 'child' must not have an ALLOCATABLE dummy argument
+!ERROR: FINAL subroutine 's07' of derived type 'child' must not have a coarray dummy argument
+!ERROR: FINAL subroutine 's08' of derived type 'child' must not have a polymorphic dummy argument
+!ERROR: FINAL subroutine 's09' of derived type 'child' must not have a polymorphic dummy argument
+!ERROR: FINAL subroutine 's10' of derived type 'child' must not have an OPTIONAL dummy argument
+    final :: s01, s02, s03, s04, s05, s06, s07, s08, s09, s10
+!ERROR: FINAL subroutine 's11' of derived type 'child' must have a single dummy argument
+!ERROR: FINAL subroutine 's12' of derived type 'child' must have a single dummy argument
+!ERROR: FINAL subroutine 's13' of derived type 'child' must have a dummy argument with an assumed LEN type parameter 'len1=*'
+!ERROR: FINAL subroutine 's13' of derived type 'child' must have a dummy argument with an assumed LEN type parameter 'len2=*'
+!ERROR: FINAL subroutine 's14' of derived type 'child' must have a dummy argument with an assumed LEN type parameter 'len2=*'
+!ERROR: FINAL subroutine 's15' of derived type 'child' must have a dummy argument with an assumed LEN type parameter 'len1=*'
+!ERROR: FINAL subroutine 's16' of derived type 'child' must not have a polymorphic dummy argument
+!ERROR: FINAL subroutine 's17' of derived type 'child' must have a TYPE(child) dummy argument
+    final :: s11, s12, s13, s14, s15, s16, s17
+!ERROR: FINAL subroutine 'valid' already appeared in this derived type
+    final :: valid
+!ERROR: FINAL subroutines 'valid2' and 'valid' of derived type 'child' cannot be distinguished by rank or KIND type parameter value
+    final :: valid2
+  end type
+ contains
+  subroutine valid(x)
+    type(child(len1=*, len2=*)), intent(inout) :: x
+  end subroutine
+  subroutine valid2(x)
+    type(child(len1=*, len2=*)), intent(inout) :: x
+  end subroutine
+  real function func(x)
+    type(child(len1=*, len2=*)), intent(inout) :: x
+    func = 0.
+  end function
+  subroutine s01(*)
+  end subroutine
+  subroutine s02(x)
+    external :: x
+  end subroutine
+  subroutine s03(x)
+    type(child(kind1=3, len1=*, len2=*)), intent(out) :: x
+  end subroutine
+  subroutine s04(x)
+    type(child(kind1=4, len1=*, len2=*)), value :: x
+  end subroutine
+  subroutine s05(x)
+    type(child(kind1=5, len1=*, len2=*)), pointer :: x
+  end subroutine
+  subroutine s06(x)
+    type(child(kind1=6, len1=*, len2=*)), allocatable :: x
+  end subroutine
+  subroutine s07(x)
+    type(child(kind1=7, len1=*, len2=*)) :: x[*]
+  end subroutine
+  subroutine s08(x)
+    class(child(kind1=8, len1=*, len2=*)) :: x
+  end subroutine
+  subroutine s09(x)
+    class(*) :: x
+  end subroutine
+  subroutine s10(x)
+    type(child(kind1=10, len1=*, len2=*)), optional :: x
+  end subroutine
+  subroutine s11(x, y)
+    type(child(kind1=11, len1=*, len2=*)) :: x, y
+  end subroutine
+  subroutine s12
+  end subroutine
+  subroutine s13(x)
+    type(child(kind1=13)) :: x
+  end subroutine
+  subroutine s14(x)
+    type(child(kind1=14, len1=*,len2=2)) :: x
+  end subroutine
+  subroutine s15(x)
+    type(child(kind1=15, len2=*)) :: x
+  end subroutine
+  subroutine s16(x)
+    type(*) :: x
+  end subroutine
+  subroutine s17(x)
+    type(parent(kind1=17, len1=*)) :: x
+  end subroutine
+  subroutine nested
+    type :: t
+     contains
+!ERROR: FINAL subroutine 'internal' of derived type 't' must be a module procedure
+      final :: internal
+    end type
+   contains
+    subroutine internal(x)
+      type(t), intent(inout) :: x
+    end subroutine
+  end subroutine
+end module

flang/test/Semantics/modfile10.f90

 !  type::t2
 !    integer(4)::x
 !  contains
-!    final::c
 !    procedure,non_overridable,private::d
+!    final::c
 !  end type
 !  type,abstract::t2a
 !  contains

flang/test/Semantics/resolve32.f90

   contains
     procedure, nopass :: b => s
     final :: f
-    !ERROR: Type parameter, component, or procedure binding 'i' already defined in this type
+    !ERROR: FINAL subroutine 'i' of derived type 't2' must be a module procedure
     final :: i
   end type
   type t3

flang/test/Semantics/resolve55.f90

   end do
 end subroutine s4
 
-subroutine s5()
+module m
 ! Cannot have a variable of a finalizable type in a locality spec
   type t1
     integer :: i
   contains
     final :: f
   end type t1
-
-  type(t1) :: var
-
+ contains
+  subroutine s5()
+    type(t1) :: var
     !ERROR: Finalizable variable 'var' not allowed in a locality-spec
     do concurrent(i=1:5) local(var)
     end do
-
-contains
+  end subroutine s5
   subroutine f(x)
     type(t1) :: x
   end subroutine f
-end subroutine s5
+end module m
 
 subroutine s6
 ! Cannot have a nonpointer polymorphic dummy argument in a locality spec