[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

 }
 extern template class Fortran::common::Indirection<
     Fortran::evaluate::characteristics::Procedure, true>;
 
 namespace Fortran::evaluate::characteristics {
 
 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 &);
 
 // Shapes of function results and dummy arguments have to have
 // the same rank, the same deferred dimensions, and the same
 // values for explicit dimensions when constant.
 bool ShapesAreCompatible(const Shape &, const Shape &);

flang/include/flang/Evaluate/type.h

public:
   constexpr const semantics::DerivedTypeSpec &GetDerivedTypeSpec() const {
     return DEREF(derived_);
   }
 
   bool RequiresDescriptor() const;
   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
   // has an erroneous type, e.g., REAL(KIND=666).
   static std::optional<DynamicType> From(const semantics::DeclTypeSpec &);
   static std::optional<DynamicType> From(const semantics::Symbol &);
 
   template <typename A> static std::optional<DynamicType> From(const A &x) {

flang/include/flang/Semantics/symbol.h

 // The DerivedTypeSpec instances whose type symbols share these details
 // each own a scope into which the components' symbols have been cloned
 // and specialized for each distinct set of type parameter values.
 class DerivedTypeDetails {
 public:
   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); }
   void add_component(const Symbol &);
   void set_sequence(bool x = true) { sequence_ = x; }
   void set_isForwardReferenced() { isForwardReferenced_ = true; }
   const std::list<SourceName> &componentNames() const {
     return componentNames_;
private:
   // 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
   // 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<<(
       llvm::raw_ostream &, const DerivedTypeDetails &);
 };
 
 class ProcBindingDetails : public WithPassArg {
 public:
public:
   void set_alignment(std::size_t alignment) { alignment_ = alignment; }
 
 private:
   MutableSymbolVector objects_;
   MaybeExpr bindName_;
   std::size_t alignment_{0}; // required alignment in bytes
 };
 
-class FinalProcDetails {}; // TODO
-
 class MiscDetails {
 public:
   ENUM_CLASS(Kind, None, ConstructName, ScopeName, PassName, ComplexPartRe,
       ComplexPartIm, KindParamInquiry, LenParamInquiry, SelectRankAssociateName,
       SelectTypeAssociateName, TypeBoundDefinedOp);
   MiscDetails(Kind kind) : kind_{kind} {}
   Kind kind() const { return kind_; }
 

 
 class UnknownDetails {};
 
 using Details = std::variant<UnknownDetails, MainProgramDetails, ModuleDetails,
     SubprogramDetails, SubprogramNameDetails, EntityDetails,
     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 &);
 
 class Symbol {
 public:
   ENUM_CLASS(Flag,
       Function, // symbol is a function
       Subroutine, // symbol is a subroutine

flang/include/flang/Semantics/tools.h

inline bool IsAssumedSizeArray(const Symbol &symbol) {
   return details && details->IsAssumedSize();
 }
 inline bool IsAssumedRankArray(const Symbol &symbol) {
   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
   return details && details->IsAssumedRank();
 }
 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 &);
 std::optional<parser::Message> WhyNotModifiable(SourceName, const SomeExpr &,
     const Scope &, bool vectorSubscriptIsOk = false);
 const Symbol *IsExternalInPureContext(const Symbol &, const Scope &);
 bool HasCoarray(const parser::Expr &);
 bool IsPolymorphicAllocatable(const Symbol &);
template <typename T> std::optional<std::int64_t> GetIntValue(const T &x) {
   }
 }
 
 template <typename T> bool IsZero(const T &expr) {
   auto value{GetIntValue(expr)};
   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
 // accepting LegacyForwardIterator.
 // The kind of component is a template argument of the iterator factory
 // ComponentIterator.
 //
 // - Ordered components are the components from the component order defined

flang/lib/Evaluate/characteristics.cpp

std::optional<TypeAndShape> TypeAndShape::Characterize(
     const ActualArgument &arg, FoldingContext &context) {
   return Characterize(arg.UnwrapExpr(), context);
 }
 
 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
     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,
         type_.AsFortran());
     return false;
   }
   return isElemental ||
       CheckConformance(messages, shape_, that.shape_, thisIs, thatIs);

flang/lib/Evaluate/tools.cpp

bool IsProcedure(const Symbol &symbol) {
   return std::visit(
       common::visitors{
           [](const SubprogramDetails &) { return true; },
           [](const SubprogramNameDetails &) { return true; },
           [](const ProcEntityDetails &) { return true; },
           [](const GenericDetails &) { return true; },
           [](const ProcBindingDetails &) { return true; },
           [](const UseDetails &x) { return IsProcedure(x.symbol()); },
-          // TODO: FinalProcDetails?
           [](const auto &) { return false; },
       },
       symbol.details());
 }
 
 const Symbol *FindCommonBlockContaining(const Symbol &object) {
   const auto *details{object.detailsIf<ObjectEntityDetails>()};
   return details ? details->commonBlock() : nullptr;

flang/lib/Evaluate/type.cpp

if (const semantics::Symbol * parent{FindParentComponent(derived)}) {
     return &parent->get<semantics::ObjectEntityDetails>()
                 .type()
                 ->derivedTypeSpec();
   } else {
     return nullptr;
   }
 }
 
-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 =
     std::set<std::pair<const semantics::DerivedTypeSpec *,
         const semantics::DerivedTypeSpec *>>;
 
 static bool AreSameComponent(const semantics::Symbol &,
     const semantics::Symbol &, SetOfDerivedTypePairs &inProgress);
static bool AreSameComponent(const semantics::Symbol &x,
     const semantics::Symbol &y,
     SetOfDerivedTypePairs & /* inProgress - not yet used */) {
   if (x.attrs() != y.attrs()) {
     return false;
   }
   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,
     const semantics::DerivedTypeSpec *y, bool isPolymorphic) {
   if (!x || !y) {
     return false;
   } else {
     SetOfDerivedTypePairs inProgress;
     if (AreSameDerivedType(*x, *y, inProgress)) {
       return true;
     } else {
       return isPolymorphic &&
           AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true);
     }
   }
 }
 
 bool IsKindTypeParameter(const semantics::Symbol &symbol) {
   const auto *param{symbol.detailsIf<semantics::TypeParamDetails>()};
   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()) {
       const semantics::ParamValue *param2{type2.FindParameter(name)};
       if (!PointeeComparison(&param1, param2)) {
         return false;
       }
     }
   }
   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_;
   }
 }
 
 std::optional<DynamicType> DynamicType::From(
     const semantics::DeclTypeSpec &type) {
   if (const auto *intrinsic{type.AsIntrinsic()}) {
     if (auto kind{ToInt64(intrinsic->kind())}) {
       TypeCategory category{intrinsic->category()};

flang/lib/Semantics/check-call.cpp

static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     characteristics::TypeAndShape &actualType, bool isElemental,
     bool actualIsArrayElement, evaluate::FoldingContext &context,
     const Scope *scope) {
 
   // Basic type & rank checking
   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(
                    characteristics::TypeAndShape::Attr::AssumedRank)) {
     } else if (!dummy.type.attrs().test(
                    characteristics::TypeAndShape::Attr::AssumedShape) &&
         (actualType.Rank() > 0 || actualIsArrayElement)) {
       // Sequence association (15.5.2.11) applies -- rank need not match
if (dummy.type.type().IsAssumedType()) {
       if (const Symbol *
           tbp{FindImmediateComponent(*derived, [](const Symbol &symbol) {
             return symbol.has<ProcBindingDetails>();
           })}) { // 15.5.2.4(2)
         evaluate::SayWithDeclaration(messages, *tbp,
             "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 (dummy.intent != common::Intent::In && !dummyIsValue) {
         if (auto bad{
                 FindAllocatableUltimateComponent(*derived)}) { // 15.5.2.4(6)
           evaluate::SayWithDeclaration(messages, *bad,
               "Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
if (actualIsUnlimited != dummyIsUnlimited) {
         // extension: allow with warning, rule is only relevant for definables
         messages.Say(
             "If a POINTER or ALLOCATABLE dummy or actual argument is polymorphic, both should be so"_en_US);
       } else {
         messages.Say(
             "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{
               evaluate::GetDerivedTypeSpec(actualType.type())}) {
         if (!DefersSameTypeParameters(
                 *derived, *evaluate::GetDerivedTypeSpec(dummy.type.type()))) {
           messages.Say(
               "Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE"_err_en_US);

flang/lib/Semantics/check-declarations.cpp

void CheckPassArg(
       const Symbol &proc, const Symbol *interface, const WithPassArg &);
   void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
   void CheckObjectEntity(const Symbol &, const ObjectEntityDetails &);
   void CheckArraySpec(const Symbol &, const ArraySpec &);
   void CheckProcEntity(const Symbol &, const ProcEntityDetails &);
   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(
       SourceName, GenericKind, const Symbol &, const Procedure &);
   std::optional<parser::MessageFixedText> CheckNumberOfArgs(
       const GenericKind &, std::size_t);
   bool CheckDefinedOperatorArg(
       const SourceName &, const Symbol &, const Procedure &, std::size_t);
if (error) {
           msg->Attach(subprogram->name(), "Containing subprogram"_en_US);
         }
       }
     }
   }
 }
 
 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) {
         if (component.attrs().test(Attr::DEFERRED)) {
           if (scope->FindComponent(component.name()) == &component) {
             SayWithDeclaration(component,
                 "Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,
                 parentDerived->typeSymbol().name(), component.name());
           }
         }
       }
     }
-    DerivedTypeSpec derived{symbol.name(), symbol};
+    DerivedTypeSpec derived{derivedType.name(), derivedType};
     derived.set_scope(*scope);
     if (FindCoarrayUltimateComponent(derived) && // C736
         !(parentDerived && FindCoarrayUltimateComponent(*parentDerived))) {
       messages_.Say(
           "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) ||
             IsEventTypeOrLockType(parentDerived))) {
       messages_.Say(
           "Type '%s' has an EVENT_TYPE or LOCK_TYPE component, so the type "
           "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(
     const Symbol &symbol, const HostAssocDetails &details) {
   const Symbol &hostSymbol{details.symbol()};
   if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) {
     if (details.implicitOrSpecExprError) {
       messages_.Say("Implicitly typed local entity '%s' not allowed in"

flang/lib/Semantics/mod-file.h

llvm::raw_string_ostream useExtraAttrs_{
       useExtraAttrsBuf_}; // attrs added to used entity
   llvm::raw_string_ostream decls_{declsBuf_};
   llvm::raw_string_ostream contains_{containsBuf_};
 
   void WriteAll(const Scope &);
   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 &);
   void PutGeneric(const Symbol &);
   void PutUse(const Symbol &);
   void PutUseExtraAttr(Attr, const Symbol &, const Symbol &);
 };
 

flang/lib/Semantics/mod-file.cpp

std::string ModFileWriter::GetAsString(const Symbol &symbol) {
   if (!str.empty()) {
     all << "contains\n" << str;
   }
   all << "end\n";
   return all.str();
 }
 
 // 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
   for (const Symbol &symbol : CollectSymbols(scope)) {
     PutSymbol(typeBindings, symbol);
   }
   if (auto str{typeBindings.str()}; !str.empty()) {
     CHECK(scope.IsDerivedType());
     decls_ << "contains\n" << str;
+    return true;
+  } else {
+    return false;
   }
 }
 
 // Emit a symbol to decls_, except for bindings in a derived type (type-bound
 // procedures, type-bound generics, final procedures) which go to typeBindings.
 void ModFileWriter::PutSymbol(
     llvm::raw_ostream &typeBindings, const Symbol &symbol) {
   std::visit(common::visitors{
std::visit(common::visitors{
                      sep = ',';
                    }
                    decls_ << '\n';
                    if (symbol.attrs().test(Attr::BIND_C)) {
                      PutAttrs(decls_, symbol.attrs(), x.bindName(), ""s);
                      decls_ << "::/" << symbol.name() << "/\n";
                    }
                  },
-                 [&](const FinalProcDetails &) {
-                   typeBindings << "final::" << symbol.name() << '\n';
-                 },
                  [](const HostAssocDetails &) {},
                  [](const MiscDetails &) {},
                  [&](const auto &) { PutEntity(decls_, symbol); },
              },
       symbol.details());
 }
 
 void ModFileWriter::PutDerivedType(const Symbol &typeSymbol) {
for (const auto &name : details.paramNames()) {
       sep = ',';
     }
     decls_ << ')';
   }
   decls_ << '\n';
   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";
 }
 
 // Attributes that may be in a subprogram prefix
 static const Attrs subprogramPrefixAttrs{Attr::ELEMENTAL, Attr::IMPURE,
     Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::RECURSIVE};
 
 void ModFileWriter::PutSubprogram(const Symbol &symbol) {

flang/lib/Semantics/pointer-assignment.cpp

if (!lhsType_) {
               " VOLATILE coarray"_err_en_US;
       }
     } else if (rhsType->type().IsUnlimitedPolymorphic()) {
       if (!LhsOkForUnlimitedPoly()) {
         msg = "Pointer type must be unlimited polymorphic or non-extensible"
               " 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()};
 
       } else if (!isBoundsRemapping_) {
         int lhsRank{evaluate::GetRank(lhsType_->shape())};
         int rhsRank{evaluate::GetRank(rhsType->shape())};
         if (lhsRank != rhsRank) {

flang/lib/Semantics/resolve-names.cpp

for (auto &bindingName : x.bindingNames) {
           context().SetError(*s);
         }
       }
     }
   }
 }
 
 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);
+          }
+        }
+      }
+    }
   }
 }
 
 bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) {
   const auto &accessSpec{std::get<std::optional<parser::AccessSpec>>(x.t)};
   const auto &genericSpec{std::get<Indirection<parser::GenericSpec>>(x.t)};
   const auto &bindingNames{std::get<std::list<parser::Name>>(x.t)};
   auto info{GenericSpecInfo{genericSpec.value()}};

flang/lib/Semantics/symbol.cpp

return std::visit(
           [](const DerivedTypeDetails &) { return "DerivedType"; },
           [](const UseDetails &) { return "Use"; },
           [](const UseErrorDetails &) { return "UseError"; },
           [](const HostAssocDetails &) { return "HostAssoc"; },
           [](const GenericDetails &) { return "Generic"; },
           [](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"; },
       },
       details);
 }
 
 const std::string Symbol::GetDetailsName() const {
std::visit( //
             if (x.alignment()) {
               os << " alignment=" << x.alignment();
             }
             os << ':';
             for (const auto &object : x.objects()) {
               os << ' ' << object->name();
             }
           },
-          [&](const FinalProcDetails &) {},
           [&](const TypeParamDetails &x) {
             DumpOptional(os, "type", x.type());
             os << ' ' << common::EnumToString(x.attr());
             DumpExpr(os, "init", x.init());
           },
           [&](const MiscDetails &x) {
             os << ' ' << MiscDetails::EnumToString(x.kind());
           },

flang/lib/Semantics/tools.cpp

if (const DeclTypeSpec * type{symbol.GetType()}) {
     if (const DerivedTypeSpec * derived{type->AsDerived()}) {
       return IsFinalizable(*derived);
     }
   }
   return false;
 }
 
 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; }
 
 bool IsAutomaticObject(const Symbol &symbol) {
   if (IsDummy(symbol) || IsPointer(symbol) || IsAllocatable(symbol)) {
     return false;
   }

 bool IsInBlankCommon(const Symbol &symbol) {
   const Symbol *block{FindCommonBlockContaining(symbol)};
   return block && block->name().empty();
 }
 
 // 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)}) {
     if (const Symbol * root{GetAssociationRoot(symbol)}) {
       if (const Symbol *
           visible{FindExternallyVisibleObject(*root, *pureProc)}) {
         return visible;
       }
if (const Symbol * submodule{proc->owner().symbol()}) {
           }
         }
       }
     }
   }
   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>
 typename ComponentIterator<componentKind>::const_iterator
 ComponentIterator<componentKind>::const_iterator::Create(
     const DerivedTypeSpec &derived) {
   const_iterator it{};
   it.componentPath_.emplace_back(derived);

flang/test/Semantics/call03.f90

module m01
   end type
 
  contains
 
   subroutine subr01(this)
     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)
     class(t), intent(in) :: x
   end subroutine
   subroutine polyassumedsize(x)
     class(t), intent(in) :: x(*)
   end subroutine
contains
   subroutine test04 ! 15.5.2.4(2)
     type(tbp) :: x
     !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have type-bound procedure 'binding'
     call typestar(x)
   end subroutine
 
   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
 
   subroutine ch2(x)
     character(2), intent(in out) :: x
   end subroutine
   subroutine test06 ! 15.5.2.4(4)
     character :: ch1

flang/test/Semantics/call05.f90

subroutine test
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
     call sup(pp)
     !ERROR: If a POINTER or ALLOCATABLE dummy or actual argument is unlimited polymorphic, both must be so
     call sua(pa)
     !ERROR: Actual argument type 'CLASS(*)' is not compatible with dummy argument type 't'
     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)
     !ERROR: Rank of dummy argument is 1, but actual argument has rank 2
     call sma(mamat)
     call sdmp(dmp) ! ok
     call sdma(dma) ! ok
     call snmp(nmp) ! ok

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

 !  contains
 !    procedure(a),deferred,nopass::q
 !    procedure(b),deferred,nopass::p
 !    procedure(b),deferred,nopass::r
 !  end type
 !  type::t2
 !    integer(4)::x
 !  contains
-!    final::c
 !    procedure,non_overridable,private::d
+!    final::c
 !  end type
 !  type,abstract::t2a
 !  contains
 !    procedure(a),deferred,nopass::e
 !  end type
 !  type::t3
 !    sequence
 !    integer(4)::i

flang/test/Semantics/resolve32.f90

contains
     !ERROR: 'bar' must be an abstract interface or a procedure with an explicit interface
     procedure(bar), nopass, deferred :: h
   end type
   type t2
     integer :: i
   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
   contains
     private
     procedure, nopass :: b => s
     procedure, nopass, public :: f
   end type
 contains
   subroutine s
   end
   subroutine f(x)
     type(t2) :: x
   end
 end module

flang/test/Semantics/resolve55.f90

 subroutine s4(arg)
 ! Cannot have a dummy INTENT(IN) in a locality spec
   real, intent(in) :: arg
 !ERROR: INTENT IN argument 'arg' not allowed in a locality-spec
   do concurrent(i=1:5) local(arg)
   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
-
+ 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
   type :: t
     integer :: field
   end type t
 contains
   subroutine s(x, y)