[flang] Check constraint C834 on INTENT(OUT) assumed-size dummy arrays

[klausler]

Summary

An assumed-size dummy array argument with INTENT(OUT) can't have a type
that might require any runtime (re)initialization, since the size of the
array is not known.

[clementval]

LGTM

flang/include/flang/Semantics/type.h

public:
   void ReplaceScope(const Scope &);
   RawParameters &rawParameters() { return rawParameters_; }
   const ParameterMapType &parameters() const { return parameters_; }
 
   bool MightBeParameterized() const;
   bool IsForwardReferenced() const;
   bool HasDefaultInitialization(bool ignoreAllocatable = false) const;
   bool HasDestruction() const;
-  bool HasFinalization() const;
 
   // The "raw" type parameter list is a simple transcription from the
   // parameter list in the parse tree, built by calling AddRawParamValue().
   // It can be used with forward-referenced derived types.
   void AddRawParamValue(const std::optional<parser::Keyword> &, ParamValue &&);
   // Checks the raw parameter list against the definition of a derived type.
   // Converts the raw parameter list to a map, naming each actual parameter.
   void CookParameters(evaluate::FoldingContext &);

flang/lib/Semantics/check-declarations.cpp

messages_.Say(
       common::maxRank) {
     messages_.Say(
         "'%s' has rank %d and corank %d, whose sum is greater than the maximum supported rank %d"_err_en_US,
         symbol.name(), details.shape().Rank(), details.coshape().Rank(),
         common::maxRank);
   }
   CheckAssumedTypeEntity(symbol, details);
   WarnMissingFinal(symbol);
+  const DeclTypeSpec *type{details.type()};
+  const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
   if (!details.coshape().empty()) {
     bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
     if (IsAllocatable(symbol)) {
       if (!isDeferredCoshape) { // C827
         messages_.Say("'%s' is an ALLOCATABLE coarray and must have a deferred"
                       " coshape"_err_en_US,
             symbol.name());
       }
     } else if (symbol.owner().IsDerivedType()) { // C746
       std::string deferredMsg{
           isDeferredCoshape ? "" : " and have a deferred coshape"};
       messages_.Say("Component '%s' is a coarray and must have the ALLOCATABLE"
                     " attribute%s"_err_en_US,
           symbol.name(), deferredMsg);
     } else {
       if (!details.coshape().CanBeAssumedSize()) { // C828
         messages_.Say(
             "'%s' is a non-ALLOCATABLE coarray and must have an explicit coshape"_err_en_US,
             symbol.name());
       }
     }
-    if (const DeclTypeSpec *type{details.type()}) {
-      if (IsBadCoarrayType(type->AsDerived())) { // C747 & C824
-        messages_.Say(
-            "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
-            symbol.name());
-      }
-    }
-  }
+    if (IsBadCoarrayType(derived)) { // C747 & C824
   if (details.isDummy()) {
-    if (symbol.attrs().test(Attr::INTENT_OUT)) {
+    if (IsIntentOut(symbol)) {
       if (FindUltimateComponent(symbol, [](const Symbol &x) {
             return evaluate::IsCoarray(x) && IsAllocatable(x);
           })) { // C846
         messages_.Say(
             "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
       }
       if (IsOrContainsEventOrLockComponent(symbol)) { // C847
         messages_.Say(
             "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
       }
+      if (details.IsAssumedSize()) { // C834
+        if (type && type->IsPolymorphic()) {
+          messages_.Say(
+              "An INTENT(OUT) assumed-size dummy argument array may not be polymorphic"_err_en_US);
+        }
+        if (derived) {
+          if (derived->HasDefaultInitialization()) {
+            messages_.Say(
+                "An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization"_err_en_US);
+          }
+          if (IsFinalizable(*derived)) {
+            messages_.Say(
+                "An INTENT(OUT) assumed-size dummy argument array may not be finalizable"_err_en_US);
+          }
+        }
+      }
     }
     if (InPure() && !IsStmtFunction(DEREF(innermostSymbol_)) &&
         !IsPointer(symbol) && !IsIntentIn(symbol) &&
         !symbol.attrs().test(Attr::VALUE)) {
       if (InFunction()) { // C1583
         messages_.Say(
             "non-POINTER dummy argument of pure function must be INTENT(IN) or VALUE"_err_en_US);
       } else if (IsIntentOut(symbol)) {
-        if (const DeclTypeSpec *type{details.type()}) {
-          if (type && type->IsPolymorphic()) { // C1588
-            messages_.Say(
-                "An INTENT(OUT) dummy argument of a pure subroutine may not be polymorphic"_err_en_US);
-          } else if (const DerivedTypeSpec *derived{type->AsDerived()}) {
-            if (FindUltimateComponent(*derived, [](const Symbol &x) {
-                  const DeclTypeSpec *type{x.GetType()};
-                  return type && type->IsPolymorphic();
-                })) { // C1588
-              messages_.Say(
-                  "An INTENT(OUT) dummy argument of a pure subroutine may not have a polymorphic ultimate component"_err_en_US);
-            }
-            if (HasImpureFinal(*derived)) { // C1587
-              messages_.Say(
-                  "An INTENT(OUT) dummy argument of a pure subroutine may not have an impure FINAL subroutine"_err_en_US);
-            }
-          }
-        }
+        } else if (derived) {
       } else if (!IsIntentInOut(symbol)) { // C1586
         messages_.Say(
             "non-POINTER dummy argument of pure subroutine must have INTENT() or VALUE attribute"_err_en_US);
       }
     }
   } else if (symbol.attrs().test(Attr::INTENT_IN) ||
       symbol.attrs().test(Attr::INTENT_OUT) ||
       symbol.attrs().test(Attr::INTENT_INOUT)) {
if (symbol.owner().kind() == Scope::Kind::BlockData) {
     if (IsAllocatable(symbol)) {
       messages_.Say(
           "An ALLOCATABLE variable may not appear in a BLOCK DATA subprogram"_err_en_US);
     } else if (IsInitialized(symbol) && !FindCommonBlockContaining(symbol)) {
       messages_.Say(
           "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
     }
   }
-  if (const DeclTypeSpec *type{details.type()}) { // C708
-    if (type->IsPolymorphic() &&
-        !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) ||
-            IsDummy(symbol))) {
-      messages_.Say("CLASS entity '%s' must be a dummy argument or have "
-                    "ALLOCATABLE or POINTER attribute"_err_en_US,
-          symbol.name());
-    }
-  }
-}
+  if (type && type->IsPolymorphic() &&
+          IsDummy(symbol))) { // C708
 
 void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
   if (IsPointer(symbol) && !context_.HasError(symbol) &&
       !scopeIsUninstantiatedPDT_) {
     if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
       if (object->init()) { // C764, C765; C808
         if (auto designator{evaluate::AsGenericExpr(symbol)}) {
           auto restorer{messages_.SetLocation(symbol.name())};

flang/test/Semantics/call29.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+module m
+  type t1
+    integer, allocatable :: a(:)
+  end type
+  type t2
+    integer :: n = 123
+  end type
+  type t3
+   contains
+    final :: t3final
+  end type
+  type t4
+    type(t1) :: c1
+    type(t2) :: c2
+    type(t3) :: c3
+  end type
+  type t5
+  end type
+ contains
+  elemental subroutine t3final(x)
+    type(t3), intent(in) :: x
+  end subroutine
+  subroutine test1(x1,x2,x3,x4,x5)
+    !ERROR: An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization
+    type(t1), intent(out) :: x1(*)
+    !ERROR: An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization
+    type(t2), intent(out) :: x2(*)
+    !ERROR: An INTENT(OUT) assumed-size dummy argument array may not be finalizable
+    type(t3), intent(out) :: x3(*)
+    !ERROR: An INTENT(OUT) assumed-size dummy argument array may not have a derived type with any default component initialization
+    !ERROR: An INTENT(OUT) assumed-size dummy argument array may not be finalizable
+    type(t4), intent(out) :: x4(*)
+    !ERROR: An INTENT(OUT) assumed-size dummy argument array may not be polymorphic
+    class(t5), intent(out) :: x5(*)
+  end subroutine
+end module