[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

   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().

flang/lib/Semantics/check-declarations.cpp

   }
   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)) {

             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
+      messages_.Say(
+          "Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
+          symbol.name());
     }
   }
   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, 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) &&

         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
+        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 (derived) {
+          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 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);
-            }
+                "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 (!IsIntentInOut(symbol)) { // C1586

           "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() &&
+      !(type->IsAssumedType() || IsAllocatableOrPointer(symbol) ||
+          IsDummy(symbol))) { // C708
+    messages_.Say("CLASS entity '%s' must be a dummy argument or have "
+                  "ALLOCATABLE or POINTER attribute"_err_en_US,
+        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