[flang] Pass call04

Original-commit: flang-compiler/f18@5a44837804
Reviewed-on: https://github.com/flang-compiler/f18/pull/783

flang/lib/semantics/check-declarations.cc

@@ -114,18 +114,16 @@ void CheckHelper::Check(Symbol &symbol) {
     Check(object->shape());
     Check(object->coshape());
     if (object->isDummy() && symbol.attrs().test(Attr::INTENT_OUT)) {
-      if (const auto *type{object->type()}) {
+      if (FindUltimateComponent(symbol,
-        if (const auto *derived{type->AsDerived()}) {
+              std::function<bool(const Symbol &)>{[](const Symbol &symbol) {
-          TypeInspector inspector;
+                return IsCoarray(symbol) && IsAllocatable(symbol);
-          inspector.Inspect(*derived);
+              }})) {  // C846
-          if (const Symbol * bad{inspector.allocatableCoarray()}) {  // C846
+        messages_.Say(
-            if (auto *msg{messages_.Say(
+            "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
-                    "An INTENT(OUT) dummy argument may not contain an ALLOCATABLE coarray"_err_en_US)}) {
+      }
-              msg->Attach(
+      if (IsOrContainsEventOrLockComponent(symbol)) {  // C847
-                  bad->name(), "Declaration of ALLOCATABLE coarray"_en_US);
+        messages_.Say(
-            }
+            "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
-          }
-        }
       }
     }
   }

flang/lib/semantics/tools.cc

@@ -1011,7 +1011,7 @@ PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
 }
 
 const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived,
-    std::function<bool(const Symbol &)> predicate) {
+    const std::function<bool(const Symbol &)> &predicate) {
   UltimateComponentIterator ultimates{derived};
   if (auto it{std::find_if(ultimates.begin(), ultimates.end(),
           [&predicate](const Symbol *component) -> bool {
@@ -1022,6 +1022,20 @@ const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived,
   return nullptr;
 }
 
+const Symbol *FindUltimateComponent(const Symbol &symbol,
+    const std::function<bool(const Symbol &)> &predicate) {
+  if (predicate(symbol)) {
+    return &symbol;
+  } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+    if (const auto *type{object->type()}) {
+      if (const auto *derived{type->AsDerived()}) {
+        return FindUltimateComponent(*derived, predicate);
+      }
+    }
+  }
+  return nullptr;
+}
+
 const Symbol *FindImmediateComponent(const DerivedTypeSpec &type,
     const std::function<bool(const Symbol &)> &predicate) {
   if (const Scope * scope{type.scope()}) {
@@ -1064,5 +1078,4 @@ bool IsFunctionResultWithSameNameAsFunction(const Symbol &symbol) {
   }
   return false;
 }
-
 }

flang/lib/semantics/tools.h

@@ -81,8 +81,10 @@ bool IsSaved(const Symbol &);
 bool CanBeTypeBoundProc(const Symbol *);
 
 // Return an ultimate component of type that matches predicate, or nullptr.
+const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,
+    const std::function<bool(const Symbol &)> &predicate);
 const Symbol *FindUltimateComponent(
-    const DerivedTypeSpec &type, std::function<bool(const Symbol &)> predicate);
+    const Symbol &symbol, const std::function<bool(const Symbol &)> &predicate);
 
 // Returns an immediate component of type that matches predicate, or nullptr.
 const Symbol *FindImmediateComponent(

flang/test/semantics/call04.f90

@@ -40,22 +40,22 @@ module m
   end subroutine
 
   subroutine s02(x) ! C846
-    !ERROR: An INTENT(OUT) dummy argument may not contain an ALLOCATABLE coarray
+    !ERROR: An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray
     type(hasCoarray), intent(out) :: x
   end subroutine
 
   subroutine s03(x) ! C846
-    !ERROR: An INTENT(OUT) dummy argument may not contain an ALLOCATABLE coarray
+    !ERROR: An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray
     type(extendsHasCoarray), intent(out) :: x
   end subroutine
 
   subroutine s04(x) ! C846
-    !ERROR: An INTENT(OUT) dummy argument may not contain an ALLOCATABLE coarray
+    !ERROR: An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray
     type(hasCoarray2), intent(out) :: x
   end subroutine
 
   subroutine s05(x) ! C846
-    !ERROR: An INTENT(OUT) dummy argument may not contain an ALLOCATABLE coarray
+    !ERROR: An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray
     type(extendsHasCoarray2), intent(out) :: x
   end subroutine
 
@@ -63,12 +63,12 @@ end module
 
 subroutine s06(x) ! C847
   use ISO_FORTRAN_ENV, only: lock_type
-  !ERROR: A dummy argument of TYPE(LOCK_TYPE) may not be INTENT(OUT)
+  !ERROR: An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE
   type(lock_type), intent(out) :: x
 end subroutine
 
 subroutine s07(x) ! C847
   use ISO_FORTRAN_ENV, only: event_type
-  !ERROR: A dummy argument of TYPE(EVENT_TYPE) may not be INTENT(OUT)
+  !ERROR: An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE
   type(event_type), intent(out) :: x
 end subroutine