[flang] Ignore FINAL subroutines with mismatching type parameters

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.

Differential Revision: https://reviews.llvm.org/D145741

flang/include/flang/Evaluate/tools.h

@@ -1227,11 +1227,6 @@ 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 &);
 

flang/include/flang/Semantics/tools.h

@@ -169,6 +169,7 @@ inline bool IsProtected(const Symbol &symbol) {
 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(

flang/lib/Evaluate/tools.cpp

@@ -1598,31 +1598,6 @@ int CountNonConstantLenParameters(const DerivedTypeSpec &type) {
   });
 }
 
-// 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());
 }

flang/lib/Evaluate/type.cpp

@@ -262,23 +262,72 @@ static bool AreSameComponent(const semantics::Symbol &x,
       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))) {
@@ -310,19 +359,23 @@ static bool AreSameDerivedType(const semantics::DerivedTypeSpec &x,
 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);
     }
   }
 }
@@ -345,9 +398,8 @@ static bool AreCompatibleTypes(const DynamicType &x, const DynamicType &y,
   } 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);
   }
 }
 
@@ -382,12 +434,13 @@ std::optional<bool> DynamicType::ExtendsTypeOf(const DynamicType &that) const {
   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;

flang/lib/Semantics/check-call.cpp

@@ -296,16 +296,14 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
             "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());
         }
       }
     }

flang/lib/Semantics/definable.cpp

@@ -228,8 +228,7 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
             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>()}) {

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

@@ -573,12 +573,11 @@ const Symbol *RuntimeTableBuilder::DescribeType(Scope &dtScope) {
       // 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,

flang/lib/Semantics/tools.cpp

@@ -702,6 +702,30 @@ bool IsSeparateModuleProcedureInterface(const Symbol *symbol) {
   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)) {
@@ -720,7 +744,7 @@ bool IsFinalizable(
 
 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;
@@ -742,14 +766,12 @@ bool IsFinalizable(const DerivedTypeSpec &derived,
 }
 
 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) {

flang/lib/Semantics/type.cpp

@@ -188,7 +188,7 @@ bool DerivedTypeSpec::HasDefaultInitialization(bool ignoreAllocatable) const {
 }
 
 bool DerivedTypeSpec::HasDestruction() const {
-  if (!typeSymbol().get<DerivedTypeDetails>().finals().empty()) {
+  if (!FinalsForDerivedTypeInstantiation(*this).empty()) {
     return true;
   }
   DirectComponentIterator components{*this};
@@ -366,7 +366,7 @@ void DerivedTypeSpec::Instantiate(Scope &containingScope) {
     }
     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) {

flang/test/Semantics/call03.f90

@@ -168,12 +168,16 @@ subroutine test06 ! 15.5.2.4(4)
     !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)

flang/test/Semantics/final03.f90

@@ -0,0 +1,28 @@
+! 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