[flang] Catch errors with INTENT(OUT) assumed rank dummy arguments (#111204)

Emit an error when an actual argument with potentially unknown size
(assumed size, or non-pointer non-allocatable assumed rank) with any
risk of needing initialization, finalization, or destruction is
associated with an INTENT(OUT) dummy argument with assumed rank.

Emit an optional portability warning for cases where the type is known
to be safe from needing initialization, finalization, or destruction,
since it's not conforming and might elicit an error from other
compilers.

Fixes https://github.com/llvm/llvm-project/issues/111120.

3 files changed, 189 insertions, 30 deletions

diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 585ca8b..fa2d59d 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -300,12 +300,15 @@ static void ConvertLogicalActual(evaluate::Expr<evaluate::SomeType> &actual,
 }
 
 static bool DefersSameTypeParameters(
-    const DerivedTypeSpec &actual, const DerivedTypeSpec &dummy) {
-  for (const auto &pair : actual.parameters()) {
-    const ParamValue &actualValue{pair.second};
-    const ParamValue *dummyValue{dummy.FindParameter(pair.first)};
-    if (!dummyValue || (actualValue.isDeferred() != dummyValue->isDeferred())) {
-      return false;
+    const DerivedTypeSpec *actual, const DerivedTypeSpec *dummy) {
+  if (actual && dummy) {
+    for (const auto &pair : actual->parameters()) {
+      const ParamValue &actualValue{pair.second};
+      const ParamValue *dummyValue{dummy->FindParameter(pair.first)};
+      if (!dummyValue ||
+          (actualValue.isDeferred() != dummyValue->isDeferred())) {
+        return false;
+      }
     }
   }
   return true;
@@ -370,9 +373,37 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   }
   bool dummyIsAssumedRank{dummy.type.attrs().test(
       characteristics::TypeAndShape::Attr::AssumedRank)};
+  bool actualIsAssumedSize{actualType.attrs().test(
+      characteristics::TypeAndShape::Attr::AssumedSize)};
+  bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
+  bool actualIsPointer{evaluate::IsObjectPointer(actual)};
+  bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
+  bool actualMayBeAssumedSize{actualIsAssumedSize ||
+      (actualIsAssumedRank && !actualIsPointer && !actualIsAllocatable)};
+  bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
+  const auto *actualDerived{evaluate::GetDerivedTypeSpec(actualType.type())};
   if (typesCompatible) {
     if (isElemental) {
     } else if (dummyIsAssumedRank) {
+      if (actualMayBeAssumedSize && dummy.intent == common::Intent::Out) {
+        // An INTENT(OUT) dummy might be a no-op at run time
+        bool dummyHasSignificantIntentOut{actualIsPolymorphic ||
+            (actualDerived &&
+                (actualDerived->HasDefaultInitialization(
+                     /*ignoreAllocatable=*/false, /*ignorePointer=*/true) ||
+                    actualDerived->HasDestruction()))};
+        const char *actualDesc{
+            actualIsAssumedSize ? "Assumed-size" : "Assumed-rank"};
+        if (dummyHasSignificantIntentOut) {
+          messages.Say(
+              "%s actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization"_err_en_US,
+              actualDesc);
+        } else {
+          context.Warn(common::UsageWarning::Portability, messages.at(),
+              "%s actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument"_port_en_US,
+              actualDesc);
+        }
+      }
     } else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
     } else if (dummyRank > 0 && !dummyIsAllocatableOrPointer &&
         !dummy.type.attrs().test(
@@ -401,11 +432,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
         dummy.type.type().AsFortran());
   }
 
-  bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
-  bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
   bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()};
-  bool actualIsAssumedSize{actualType.attrs().test(
-      characteristics::TypeAndShape::Attr::AssumedSize)};
   bool dummyIsAssumedSize{dummy.type.attrs().test(
       characteristics::TypeAndShape::Attr::AssumedSize)};
   bool dummyIsAsynchronous{
@@ -414,7 +441,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Volatile)};
   bool dummyIsValue{
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)};
-
+  bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()};
   if (actualIsPolymorphic && dummyIsPolymorphic &&
       actualIsCoindexed) { // 15.5.2.4(2)
     messages.Say(
@@ -434,37 +461,36 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::ASYNCHRONOUS)};
   bool actualIsVolatile{
       actualFirstSymbol && actualFirstSymbol->attrs().test(Attr::VOLATILE)};
-  const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())};
-  if (derived && !derived->IsVectorType()) {
+  if (actualDerived && !actualDerived->IsVectorType()) {
     if (dummy.type.type().IsAssumedType()) {
-      if (!derived->parameters().empty()) { // 15.5.2.4(2)
+      if (!actualDerived->parameters().empty()) { // 15.5.2.4(2)
         messages.Say(
             "Actual argument associated with TYPE(*) %s may not have a parameterized derived type"_err_en_US,
             dummyName);
       }
       if (const Symbol *
-          tbp{FindImmediateComponent(*derived, [](const Symbol &symbol) {
+          tbp{FindImmediateComponent(*actualDerived, [](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());
       }
-      auto finals{FinalsForDerivedTypeInstantiation(*derived)};
+      auto finals{FinalsForDerivedTypeInstantiation(*actualDerived)};
       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(), name)}) {
+                dummyName, actualDerived->typeSymbol().name(), name)}) {
           msg->Attach(name, "FINAL subroutine '%s' in derived type '%s'"_en_US,
-              name, derived->typeSymbol().name());
+              name, actualDerived->typeSymbol().name());
         }
       }
     }
     if (actualIsCoindexed) {
       if (dummy.intent != common::Intent::In && !dummyIsValue) {
-        if (auto bad{
-                FindAllocatableUltimateComponent(*derived)}) { // 15.5.2.4(6)
+        if (auto bad{FindAllocatableUltimateComponent(
+                *actualDerived)}) { // 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,
               bad.BuildResultDesignatorName(), dummyName);
@@ -484,7 +510,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
       }
     }
     if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
-      if (auto bad{semantics::FindCoarrayUltimateComponent(*derived)}) {
+      if (auto bad{semantics::FindCoarrayUltimateComponent(*actualDerived)}) {
         evaluate::SayWithDeclaration(messages, *bad,
             "VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
             dummyName, bad.BuildResultDesignatorName());
@@ -501,8 +527,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           ? actualLastSymbol->detailsIf<ObjectEntityDetails>()
           : nullptr};
   int actualRank{actualType.Rank()};
-  bool actualIsPointer{evaluate::IsObjectPointer(actual)};
-  bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
   if (dummy.type.attrs().test(
           characteristics::TypeAndShape::Attr::AssumedShape)) {
     // 15.5.2.4(16)
@@ -730,7 +754,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   }
 
   // 15.5.2.6 -- dummy is ALLOCATABLE
-  bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
   bool dummyIsOptional{
       dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)};
   bool actualIsNull{evaluate::IsNullPointer(actual)};
@@ -851,10 +874,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
         }
       }
       // 15.5.2.5(4)
-      const auto *derived{evaluate::GetDerivedTypeSpec(actualType.type())};
-      if ((derived &&
-              !DefersSameTypeParameters(*derived,
-                  *evaluate::GetDerivedTypeSpec(dummy.type.type()))) ||
+      const auto *dummyDerived{evaluate::GetDerivedTypeSpec(dummy.type.type())};
+      if (!DefersSameTypeParameters(actualDerived, dummyDerived) ||
           dummy.type.type().HasDeferredTypeParameter() !=
               actualType.type().HasDeferredTypeParameter()) {
         messages.Say(
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 904d43d..4d2a0a6 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -688,7 +688,7 @@ bool IsInitialized(const Symbol &symbol, bool ignoreDataStatements,
   } else if (IsNamedConstant(symbol)) {
     return false;
   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
-    if (!object->isDummy() && object->type()) {
+    if ((!object->isDummy() || IsIntentOut(symbol)) && object->type()) {
       if (const auto *derived{object->type()->AsDerived()}) {
         return derived->HasDefaultInitialization(
             ignoreAllocatable, ignorePointer);
@@ -705,7 +705,7 @@ bool IsDestructible(const Symbol &symbol, const Symbol *derivedTypeSymbol) {
       IsPointer(symbol)) {
     return false;
   } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
-    if (!object->isDummy() && object->type()) {
+    if ((!object->isDummy() || IsIntentOut(symbol)) && object->type()) {
       if (const auto *derived{object->type()->AsDerived()}) {
         return &derived->typeSymbol() != derivedTypeSymbol &&
             derived->HasDestruction();
diff --git a/flang/test/Semantics/call42.f90 b/flang/test/Semantics/call42.f90
new file mode 100644
index 0000000..2d5303b
--- /dev/null
+++ b/flang/test/Semantics/call42.f90
@@ -0,0 +1,138 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+module m
+  type boring
+  end type
+  type hasAlloc
+    real, allocatable :: x
+  end type
+  type hasInit
+    real :: x = 1.
+  end type
+  type hasFinal
+   contains
+    final final
+  end type
+ contains
+  elemental subroutine final(x)
+    type(hasFinal), intent(in out) :: x
+  end
+
+  recursive subroutine typeOutAssumedRank(a,b,c,d)
+    type(boring), intent(out) :: a(..)
+    type(hasAlloc), intent(out) :: b(..)
+    type(hasInit), intent(out) :: c(..)
+    type(hasFinal), intent(out) :: d(..)
+    !PORTABILITY: Assumed-rank actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call typeOutAssumedRank(a, b, c, d)
+    !PORTABILITY: Assumed-rank actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call classOutAssumedRank(a, b, c, d)
+    !PORTABILITY: Assumed-rank actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call unlimitedOutAssumedRank(a, b, c, d)
+  end
+  recursive subroutine typeOutAssumedRankAlloc(a,b,c,d)
+    type(boring), intent(out), allocatable :: a(..)
+    type(hasAlloc), intent(out), allocatable :: b(..)
+    type(hasInit), intent(out), allocatable :: c(..)
+    type(hasFinal), intent(out), allocatable :: d(..)
+    call typeOutAssumedRank(a, b, c, d)
+    call typeOutAssumedRankAlloc(a, b, c, d)
+  end
+  recursive subroutine classOutAssumedRank(a,b,c,d)
+    class(boring), intent(out) :: a(..)
+    class(hasAlloc), intent(out) :: b(..)
+    class(hasInit), intent(out) :: c(..)
+    class(hasFinal), intent(out) :: d(..)
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call typeOutAssumedRank(a, b, c, d)
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call classOutAssumedRank(a, b, c, d)
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call unlimitedOutAssumedRank(a, b, c, d)
+  end
+  recursive subroutine classOutAssumedRankAlloc(a,b,c,d)
+    class(boring), intent(out), allocatable :: a(..)
+    class(hasAlloc), intent(out), allocatable :: b(..)
+    class(hasInit), intent(out), allocatable :: c(..)
+    class(hasFinal), intent(out), allocatable :: d(..)
+    call classOutAssumedRank(a, b, c, d)
+    call classOutAssumedRankAlloc(a, b, c, d)
+    call unlimitedOutAssumedRank(a, b, c, d)
+  end
+  recursive subroutine unlimitedOutAssumedRank(a,b,c,d)
+    class(*), intent(out) :: a(..), b(..), c(..), d(..)
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-rank actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call unlimitedOutAssumedRank(a, b, c, d)
+  end
+  recursive subroutine unlimitedOutAssumedRankAlloc(a,b,c,d)
+    class(*), intent(out), allocatable :: a(..), b(..), c(..), d(..)
+    call unlimitedOutAssumedRank(a, b, c, d)
+    call unlimitedOutAssumedRankAlloc(a, b, c, d)
+  end
+
+  subroutine typeAssumedSize(a,b,c,d)
+    type(boring) a(*)
+    type(hasAlloc) b(*)
+    type(hasInit) c(*)
+    type(hasFinal) d(*)
+    !PORTABILITY: Assumed-size actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call typeOutAssumedRank(a,b,c,d)
+    !PORTABILITY: Assumed-size actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call classOutAssumedRank(a,b,c,d)
+    !PORTABILITY: Assumed-size actual argument should not be associated with INTENT(OUT) assumed-rank dummy argument
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call unlimitedOutAssumedRank(a,b,c,d)
+  end
+  subroutine classAssumedSize(a,b,c,d)
+    class(boring) a(*)
+    class(hasAlloc) b(*)
+    class(hasInit) c(*)
+    class(hasFinal) d(*)
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call classOutAssumedRank(a,b,c,d)
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call unlimitedOutAssumedRank(a,b,c,d)
+  end
+  subroutine unlimitedAssumedSize(a,b,c,d)
+    class(*) a(*), b(*), c(*), d(*)
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    !ERROR: Assumed-size actual argument may not be associated with INTENT(OUT) assumed-rank dummy argument requiring finalization, destruction, or initialization
+    call unlimitedOutAssumedRank(a, b, c, d)
+  end
+end