[flang] Ignore FINAL subroutines with mismatching type parameters

[klausler]

Summary

When a parameterized derived type has FINAL subroutines, only
those FINAL subroutines whose dummy argument's type matches the
type parameter values of a particular instantiation are relevant
to that instantiation.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Evaluate/tools.h

 const Symbol &ResolveAssociations(const Symbol &);
 const Symbol &GetAssociationRoot(const Symbol &);
 const Symbol &ResolveAssociationsExceptSelectRank(const Symbol &);
 
 const Symbol *FindCommonBlockContaining(const Symbol &);
 int CountLenParameters(const DerivedTypeSpec &);
 int CountNonConstantLenParameters(const DerivedTypeSpec &);
 
-// 15.5.2.4(4), type compatibility for dummy and actual arguments.
-// Also used for assignment compatibility checking
-bool AreTypeParamCompatible(
-    const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
-
 const Symbol &GetUsedModule(const UseDetails &);
 const Symbol *FindFunctionResult(const Symbol &);
 
 // Type compatibility predicate: are x and y effectively the same type?
 // Uses DynamicType::IsTkCompatible(), which handles the case of distinct
 // but identical derived types.
 bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
 
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/include/flang/Semantics/tools.h

inline bool IsIntentOut(const Symbol &symbol) {
   return symbol.attrs().test(Attr::INTENT_OUT);
 }
 inline bool IsProtected(const Symbol &symbol) {
   return symbol.attrs().test(Attr::PROTECTED);
 }
 inline bool IsImpliedDoIndex(const Symbol &symbol) {
   return symbol.owner().kind() == Scope::Kind::ImpliedDos;
 }
+SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &);
 bool IsFinalizable(
     const Symbol &, std::set<const DerivedTypeSpec *> * = nullptr);
 bool IsFinalizable(
     const DerivedTypeSpec &, std::set<const DerivedTypeSpec *> * = nullptr);
 bool HasImpureFinal(const DerivedTypeSpec &);
 bool IsInBlankCommon(const Symbol &);
 inline bool IsAssumedSizeArray(const Symbol &symbol) {
   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};

flang/lib/Evaluate/tools.cpp

return llvm::count_if(type.parameters(), [](const auto &pair) {
     } else if (const auto &expr{pair.second.GetExplicit()}) {
       return !IsConstantExpr(*expr);
     } else {
       return true;
     }
   });
 }
 
-// Are the type parameters of type1 compile-time compatible with the
-// corresponding kind type parameters of type2?  Return true if all constant
-// valued parameters are equal.
-// Used to check assignment statements and argument passing.  See 15.5.2.4(4)
-bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &type1,
-    const semantics::DerivedTypeSpec &type2) {
-  for (const auto &[name, param1] : type1.parameters()) {
-    if (semantics::MaybeIntExpr paramExpr1{param1.GetExplicit()}) {
-      if (IsConstantExpr(*paramExpr1)) {
-        const semantics::ParamValue *param2{type2.FindParameter(name)};
-        if (param2) {
-          if (semantics::MaybeIntExpr paramExpr2{param2->GetExplicit()}) {
-            if (IsConstantExpr(*paramExpr2)) {
-              if (ToInt64(*paramExpr1) != ToInt64(*paramExpr2)) {
-                return false;
-              }
-            }
-          }
-        }
-      }
-    }
-  }
-  return true;
-}
-
 const Symbol &GetUsedModule(const UseDetails &details) {
   return DEREF(details.symbol().owner().symbol());
 }
 
 static const Symbol *FindFunctionResult(
     const Symbol &original, UnorderedSymbolSet &seen) {
   const Symbol &root{GetAssociationRoot(original)};
   ;

flang/lib/Evaluate/type.cpp

static bool AreSameComponent(const semantics::Symbol &x,
   if (x.attrs().test(semantics::Attr::PRIVATE)) {
     return false;
   }
   // TODO: compare types, parameters, bounds, &c.
   return x.has<semantics::ObjectEntityDetails>() ==
       y.has<semantics::ObjectEntityDetails>();
 }
 
+static bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &x,
+    const semantics::DerivedTypeSpec &y, bool ignoreLenParameters) {
+  const auto *xScope{x.typeSymbol().scope()};
+  const auto *yScope{y.typeSymbol().scope()};
+  for (const auto &[paramName, value] : x.parameters()) {
+    const auto *yValue{y.FindParameter(paramName)};
+    if (!yValue) {
+      return false;
+    }
+    const auto *xParm{xScope ? xScope->FindComponent(paramName) : nullptr};
+    const auto *yParm{yScope ? yScope->FindComponent(paramName) : nullptr};
+    if (xParm && yParm) {
+      const auto *xTPD{xParm->detailsIf<semantics::TypeParamDetails>()};
+      const auto *yTPD{yParm->detailsIf<semantics::TypeParamDetails>()};
+      if (xTPD && yTPD) {
+        if (xTPD->attr() != yTPD->attr()) {
+          return false;
+        }
+        if (!ignoreLenParameters ||
+            xTPD->attr() != common::TypeParamAttr::Len) {
+          auto xExpr{value.GetExplicit()};
+          auto yExpr{yValue->GetExplicit()};
+          if (xExpr && yExpr) {
+            auto xVal{ToInt64(*xExpr)};
+            auto yVal{ToInt64(*yExpr)};
+            if (xVal && yVal && *xVal != *yVal) {
+              return false;
+            }
+          }
+        }
+      }
+    }
+  }
+  for (const auto &[paramName, _] : y.parameters()) {
+    if (!x.FindParameter(paramName)) {
+      return false; // y has more parameters than x
+    }
+  }
+  return true;
+}
+
 static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
-    const semantics::DerivedTypeSpec &y, SetOfDerivedTypePairs &inProgress) {
+    const semantics::DerivedTypeSpec &y, bool ignoreTypeParameterValues,
+    bool ignoreLenParameters, SetOfDerivedTypePairs &inProgress) {
+  if (&x == &y) {
+    return true;
+  }
+  if (!ignoreTypeParameterValues &&
+      !AreTypeParamCompatible(x, y, ignoreLenParameters)) {
+    return false;
+  }
   const auto &xSymbol{x.typeSymbol()};
   const auto &ySymbol{y.typeSymbol()};
-  if (&x == &y || xSymbol == ySymbol) {
+  if (xSymbol == ySymbol) {
     return true;
   }
+  if (xSymbol.name() != ySymbol.name()) {
+    return false;
+  }
   auto thisQuery{std::make_pair(&x, &y)};
   if (inProgress.find(thisQuery) != inProgress.end()) {
     return true; // recursive use of types in components
   }
   inProgress.insert(thisQuery);
   const auto &xDetails{xSymbol.get<semantics::DerivedTypeDetails>()};
   const auto &yDetails{ySymbol.get<semantics::DerivedTypeDetails>()};
-  if (xSymbol.name() != ySymbol.name()) {
-    return false;
-  }
   if (!(xDetails.sequence() && yDetails.sequence()) &&
       !(xSymbol.attrs().test(semantics::Attr::BIND_C) &&
           ySymbol.attrs().test(semantics::Attr::BIND_C))) {
     // PGI does not enforce this requirement; all other Fortran
     // processors do with a hard error when violations are caught.
     return false;
   }
   // Compare the component lists in their orders of declaration.
for (auto xComponentName{xDetails.componentNames().cbegin()};
     }
   }
   return yComponentName == yEnd;
 }
 
 bool AreSameDerivedType(
     const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y) {
   SetOfDerivedTypePairs inProgress;
-  return AreSameDerivedType(x, y, inProgress);
+  return AreSameDerivedType(x, y, false, false, inProgress);
 }
 
 static bool AreCompatibleDerivedTypes(const semantics::DerivedTypeSpec *x,
-    const semantics::DerivedTypeSpec *y, bool isPolymorphic) {
+    const semantics::DerivedTypeSpec *y, bool isPolymorphic,
+    bool ignoreTypeParameterValues, bool ignoreLenTypeParameters) {
   if (!x || !y) {
     return false;
   } else {
-    if (AreSameDerivedType(*x, *y)) {
+    SetOfDerivedTypePairs inProgress;
+    if (AreSameDerivedType(*x, *y, ignoreTypeParameterValues,
+            ignoreLenTypeParameters, inProgress)) {
       return true;
     } else {
       return isPolymorphic &&
-          AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true);
+          AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true,
+              ignoreTypeParameterValues, ignoreLenTypeParameters);
     }
   }
 }
 
 static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
     bool ignoreTypeParameterValues, bool ignoreLengths) {
   if (x.IsUnlimitedPolymorphic()) {
     return true;
   } else if (y.IsUnlimitedPolymorphic()) {
     return false;
   } else if (x.category() != y.category()) {
     return false;
   } else if (x.category() == TypeCategory::Character) {
     const auto xLen{x.knownLength()};
     const auto yLen{y.knownLength()};
     return x.kind() == y.kind() &&
         (ignoreLengths || !xLen || !yLen || *xLen == *yLen);
   } else if (x.category() != TypeCategory::Derived) {
     return x.kind() == y.kind();
   } else {
     const auto *xdt{GetDerivedTypeSpec(x)};
     const auto *ydt{GetDerivedTypeSpec(y)};
-    return AreCompatibleDerivedTypes(xdt, ydt, x.IsPolymorphic()) &&
-        (ignoreTypeParameterValues ||
-            (xdt && ydt && AreTypeParamCompatible(*xdt, *ydt)));
+    return AreCompatibleDerivedTypes(
+        xdt, ydt, x.IsPolymorphic(), ignoreTypeParameterValues, false);
   }
 }
 
 // See 7.3.2.3 (5) & 15.5.2.4
 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
   return AreCompatibleTypes(*this, that, false, true);
 }
 

 std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
   if (IsUnlimitedPolymorphic() || that.IsUnlimitedPolymorphic()) {
     return std::nullopt; // unknown
   }
   const auto *thisDts{evaluate::GetDerivedTypeSpec(*this)};
   const auto *thatDts{evaluate::GetDerivedTypeSpec(that)};
   if (!thisDts || !thatDts) {
     return std::nullopt;
-  } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true)) {
+  } else if (!AreCompatibleDerivedTypes(thatDts, thisDts, true, true, true)) {
     // Note that I check *thisDts, not its parent, so that EXTENDS_TYPE_OF()
     // is .true. when they are the same type.  This is technically
     // an implementation-defined case in the standard, but every other
     // compiler works this way.
-    if (IsPolymorphic() && AreCompatibleDerivedTypes(thisDts, thatDts, true)) {
+    if (IsPolymorphic() &&
+        AreCompatibleDerivedTypes(thisDts, thatDts, true, true, true)) {
       // 'that' is *this or an extension of *this, and so runtime *this
       // could be an extension of 'that'
       return std::nullopt;
     } else {
       return false;
     }
   } else if (that.IsPolymorphic()) {
     return std::nullopt; // unknown

flang/lib/Semantics/check-call.cpp

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());
       }
-      const auto &finals{
-          derived->typeSymbol().get<DerivedTypeDetails>().finals()};
+      auto finals{FinalsForDerivedTypeInstantiation(*derived)};
       if (!finals.empty()) { // 15.5.2.4(2)
+        SourceName name{finals.front()->name()};
         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());
+                dummyName, derived->typeSymbol().name(), name)}) {
+          msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US,
+              name, 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,

flang/lib/Semantics/definable.cpp

if (evaluate::HasVectorSubscript(expr)) {
             // If there's an elemental FINAL subroutine, all is well; otherwise,
             // if there is a FINAL subroutine with a matching or assumed rank
             // dummy argument, there's no way to call it.
             int rank{expr.Rank()};
             const DerivedTypeSpec *spec{&type->GetDerivedTypeSpec()};
             while (spec) {
               bool anyElemental{false};
               const Symbol *anyRankMatch{nullptr};
-              for (const auto &[_, ref] :
-                  spec->typeSymbol().get<DerivedTypeDetails>().finals()) {
+              for (auto ref : FinalsForDerivedTypeInstantiation(*spec)) {
                 const Symbol &ultimate{ref->GetUltimate()};
                 anyElemental |= ultimate.attrs().test(Attr::ELEMENTAL);
                 if (const auto *subp{ultimate.detailsIf<SubprogramDetails>()}) {
                   if (!subp->dummyArgs().empty()) {
                     if (const Symbol * arg{subp->dummyArgs()[0]}) {
                       const auto *object{arg->detailsIf<ObjectEntityDetails>()};
                       if (arg->Rank() == rank ||
                           (object && object->IsAssumedRank())) {

flang/lib/Semantics/runtime-type-info.cpp

if (!isAbstractType) {
               evaluate::ConstantSubscripts{
                   static_cast<evaluate::ConstantSubscript>(bindings.size())}));
       // Describe "special" bindings to defined assignments, FINAL subroutines,
       // and user-defined derived type I/O subroutines.  Defined assignments
       // and I/O subroutines override any parent bindings; FINAL subroutines
       // do not (the runtime will call all of them).
       std::map<int, evaluate::StructureConstructor> specials{
           DescribeSpecialGenerics(dtScope, dtScope, derivedTypeSpec)};
-      const DerivedTypeDetails &dtDetails{dtSymbol->get<DerivedTypeDetails>()};
-      for (const auto &pair : dtDetails.finals()) {
-        DescribeSpecialProc(specials, *pair.second, false /*!isAssignment*/,
-            true, std::nullopt, nullptr, derivedTypeSpec);
-      }
       if (derivedTypeSpec) {
+        for (auto &ref : FinalsForDerivedTypeInstantiation(*derivedTypeSpec)) {
+          DescribeSpecialProc(specials, *ref, false /*!isAssignment*/, true,
+              std::nullopt, nullptr, derivedTypeSpec);
+        }
         IncorporateDefinedIoGenericInterfaces(specials,
             GenericKind::DefinedIo::ReadFormatted, &scope, derivedTypeSpec);
         IncorporateDefinedIoGenericInterfaces(specials,
             GenericKind::DefinedIo::ReadUnformatted, &scope, derivedTypeSpec);
         IncorporateDefinedIoGenericInterfaces(specials,
             GenericKind::DefinedIo::WriteFormatted, &scope, derivedTypeSpec);
         IncorporateDefinedIoGenericInterfaces(specials,
             GenericKind::DefinedIo::WriteUnformatted, &scope, derivedTypeSpec);

flang/lib/Semantics/tools.cpp

bool IsSeparateModuleProcedureInterface(const Symbol *symbol) {
   if (symbol && symbol->attrs().test(Attr::MODULE)) {
     if (auto *details{symbol->detailsIf<SubprogramDetails>()}) {
       return details->isInterface();
     }
   }
   return false;
 }
 
+SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &spec) {
+  SymbolVector result;
+  const Symbol &typeSymbol{spec.typeSymbol()};
+  if (const auto *derived{typeSymbol.detailsIf<DerivedTypeDetails>()}) {
+    for (const auto &pair : derived->finals()) {
+      const Symbol &subr{*pair.second};
+      // Errors in FINAL subroutines are caught in CheckFinal
+      // in check-declarations.cpp.
+      if (const auto *subprog{subr.detailsIf<SubprogramDetails>()};
+          subprog && subprog->dummyArgs().size() == 1) {
+        if (const Symbol * arg{subprog->dummyArgs()[0]}) {
+          if (const DeclTypeSpec * type{arg->GetType()}) {
+            if (type->category() == DeclTypeSpec::TypeDerived &&
+                evaluate::AreSameDerivedType(spec, type->derivedTypeSpec())) {
+              result.emplace_back(subr);
+            }
+          }
+        }
+      }
+    }
+  }
+  return result;
+}
+
 bool IsFinalizable(
     const Symbol &symbol, std::set<const DerivedTypeSpec *> *inProgress) {
   if (IsPointer(symbol)) {
     return false;
   }
   if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
     if (object->isDummy() && !IsIntentOut(symbol)) {
       return false;
     }
     const DeclTypeSpec *type{object->type()};
     const DerivedTypeSpec *typeSpec{type ? type->AsDerived() : nullptr};
     return typeSpec && IsFinalizable(*typeSpec, inProgress);
   }
   return false;
 }
 
 bool IsFinalizable(const DerivedTypeSpec &derived,
     std::set<const DerivedTypeSpec *> *inProgress) {
-  if (!derived.typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
+  if (!FinalsForDerivedTypeInstantiation(derived).empty()) {
     return true;
   }
   std::set<const DerivedTypeSpec *> basis;
   if (inProgress) {
     if (inProgress->find(&derived) != inProgress->end()) {
       return false; // don't loop on recursive type
     }
   } else {
     inProgress = &basis;
   }
   auto iterator{inProgress->insert(&derived).first};
   PotentialComponentIterator components{derived};
   bool result{bool{std::find_if(
       components.begin(), components.end(), [=](const Symbol &component) {
         return IsFinalizable(component, inProgress);
       })}};
   inProgress->erase(iterator);
   return result;
 }
 
 bool HasImpureFinal(const DerivedTypeSpec &derived) {
-  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 !IsPureProcedure(*x.second); });
-  } else {
-    return false;
+  for (auto ref : FinalsForDerivedTypeInstantiation(derived)) {
+    if (!IsPureProcedure(*ref)) {
+      return true;
+    }
   }
+  return false;
 }
 
 bool IsAssumedLengthCharacter(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     return type->category() == DeclTypeSpec::Character &&
         type->characterTypeSpec().length().isAssumed();
   } else {
     return false;

flang/lib/Semantics/type.cpp

bool DerivedTypeSpec::HasDefaultInitialization(bool ignoreAllocatable) const {
   DirectComponentIterator components{*this};
   return bool{std::find_if(
       components.begin(), components.end(), [&](const Symbol &component) {
         return IsInitialized(component, true, ignoreAllocatable);
       })};
 }
 
 bool DerivedTypeSpec::HasDestruction() const {
-  if (!typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
+  if (!FinalsForDerivedTypeInstantiation(*this).empty()) {
     return true;
   }
   DirectComponentIterator components{*this};
   return bool{std::find_if(
       components.begin(), components.end(), [&](const Symbol &component) {
         return IsDestructible(component, &typeSymbol());
       })};
 }
if (sep != '(') {
     desc += ')';
     contextMessage = new parser::Message{foldingContext.messages().at(),
         "instantiation of parameterized derived type '%s'"_en_US, desc};
     if (auto outer{containingScope.instantiationContext()}) {
       contextMessage->SetContext(outer.get());
     }
     newScope.set_instantiationContext(contextMessage);
   }
-  // Instantiate every non-parameter symbol from the original derived
+  // Instantiate nearly every non-parameter symbol from the original derived
   // type's scope into the new instance.
   auto restorer2{foldingContext.messages().SetContext(contextMessage)};
   if (PlumbPDTInstantiationDepth(&containingScope) > 100) {
     foldingContext.messages().Say(
         "Too many recursive parameterized derived type instantiations"_err_en_US);
   } else {
     InstantiateHelper{newScope}.InstantiateComponents(typeScope);
   }

flang/test/Semantics/call03.f90

subroutine test06 ! 15.5.2.4(4)
     type(pdtWithDefault(3)) :: defaultVar3
     type(pdtWithDefault(4)) :: defaultVar4
     character :: ch1
     !ERROR: Actual argument variable length '1' is less than expected length '2'
     call ch2(ch1)
     !WARNING: Actual argument expression length '0' is less than expected length '2'
     call ch2("")
     call pdtdefault(vardefault)
+    !ERROR: Actual argument type 'pdt(n=3_4)' is not compatible with dummy argument type 'pdt'
     call pdtdefault(var3)
+    !ERROR: Actual argument type 'pdt(n=4_4)' is not compatible with dummy argument type 'pdt'
     call pdtdefault(var4) ! error
-    call pdt3(vardefault) ! error
+    !ERROR: Actual argument type 'pdt' is not compatible with dummy argument type 'pdt(n=4_4)'
+    call pdt3(vardefault)
     !ERROR: Actual argument type 'pdt(n=3_4)' is not compatible with dummy argument type 'pdt(n=4_4)'
-    call pdt3(var3) ! error
+    call pdt3(var3)
     call pdt3(var4)
+    !ERROR: Actual argument type 'pdt' is not compatible with dummy argument type 'pdt(n=*)'
     call pdt4(vardefault)
     call pdt4(var3)
     call pdt4(var4)
     call pdtWithDefaultdefault(defaultVardefault)
     call pdtWithDefaultdefault(defaultVar3)
     !ERROR: Actual argument type 'pdtwithdefault(n=4_4)' is not compatible with dummy argument type 'pdtwithdefault(n=3_4)'
     call pdtWithDefaultdefault(defaultVar4) ! error
     !ERROR: Actual argument type 'pdtwithdefault(n=3_4)' is not compatible with dummy argument type 'pdtwithdefault(n=4_4)'

flang/test/Semantics/final03.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+! PDT sensitivity of FINAL subroutines
+module m
+  type :: pdt(k)
+    integer, kind :: k
+   contains
+    final :: finalArr, finalElem
+  end type
+ contains
+  subroutine finalArr(x)
+    type(pdt(1)), intent(in out) :: x(:)
+  end
+  elemental subroutine finalElem(x)
+    type(pdt(3)), intent(in out) :: x
+  end
+end
+
+program test
+  use m
+  type(pdt(1)) x1(1)
+  type(pdt(2)) x2(1)
+  type(pdt(3)) x3(1)
+  !ERROR: Left-hand side of assignment is not definable
+  !BECAUSE: Variable 'x1([INTEGER(8)::1_8])' has a vector subscript and cannot be finalized by non-elemental subroutine 'finalarr'
+  x1([1]) = pdt(1)()
+  x2([1]) = pdt(2)() ! ok, doesn't match either
+  x3([1]) = pdt(3)() ! ok, calls finalElem
+end