[flang] Refine EVENT_TYPE/LOCK_TYPE usage checks (#123244)

The event variable in an EVENT POST/WAIT statement can be a coarray
reference, and need not be an entire coarray.

Variables and potential subobject components with EVENT_TYPE/LOCK_TYPE
must be coarrays, unless they are potential subobjects nested within
coarrays or pointers.

Author: klausler

flang/include/flang/Semantics/tools.h

@@ -529,6 +529,9 @@ template <ComponentKind componentKind> class ComponentIterator {
     // having to check against an end() iterator.
     explicit operator bool() const { return !componentPath_.empty(); }
 
+    // Returns the current sequence of components, including parent components.
+    SymbolVector GetComponentPath() const;
+
     // Builds a designator name of the referenced component for messages.
     // The designator helps when the component referred to by the iterator
     // may be "buried" into other components. This gives the full
@@ -626,7 +629,7 @@ using PotentialAndPointerComponentIterator =
 // is returned. Otherwise, the returned iterator casts to true and can be
 // dereferenced.
 PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
-    const DerivedTypeSpec &);
+    const DerivedTypeSpec &, bool ignoreCoarrays = false);
 UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
     const DerivedTypeSpec &);
 UltimateComponentIterator::const_iterator FindPointerUltimateComponent(

flang/lib/Semantics/check-coarray.cpp

@@ -133,9 +133,6 @@ static void CheckEventVariable(
     if (!IsEventType(evaluate::GetDerivedTypeSpec(expr->GetType()))) { // C1176
       context.Say(parser::FindSourceLocation(eventVar),
           "The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
-    } else if (!evaluate::IsCoarray(*expr)) { // C1604
-      context.Say(parser::FindSourceLocation(eventVar),
-          "The event-variable must be a coarray"_err_en_US);
     }
   }
 }

flang/lib/Semantics/check-declarations.cpp

@@ -683,7 +683,20 @@ void CheckHelper::CheckObjectEntity(
   const DeclTypeSpec *type{details.type()};
   const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
   bool isComponent{symbol.owner().IsDerivedType()};
-  if (!details.coshape().empty()) {
+  if (details.coshape().empty()) { // not a coarray
+    if (!isComponent && !IsPointer(symbol) && derived) {
+      if (IsEventTypeOrLockType(derived)) {
+        messages_.Say(
+            "Variable '%s' with EVENT_TYPE or LOCK_TYPE must be a coarray"_err_en_US,
+            symbol.name());
+      } else if (auto component{FindEventOrLockPotentialComponent(
+                     *derived, /*ignoreCoarrays=*/true)}) {
+        messages_.Say(
+            "Variable '%s' with EVENT_TYPE or LOCK_TYPE potential component '%s' must be a coarray"_err_en_US,
+            symbol.name(), component.BuildResultDesignatorName());
+      }
+    }
+  } else { // it's a coarray
     bool isDeferredCoshape{details.coshape().CanBeDeferredShape()};
     if (IsAllocatable(symbol)) {
       if (!isDeferredCoshape) { // C827

flang/lib/Semantics/tools.cpp

@@ -1364,13 +1364,23 @@ void ComponentIterator<componentKind>::const_iterator::Increment() {
   }
 }
 
+template <ComponentKind componentKind>
+SymbolVector
+ComponentIterator<componentKind>::const_iterator::GetComponentPath() const {
+  SymbolVector result;
+  for (const auto &node : componentPath_) {
+    result.push_back(DEREF(node.component()));
+  }
+  return result;
+}
+
 template <ComponentKind componentKind>
 std::string
 ComponentIterator<componentKind>::const_iterator::BuildResultDesignatorName()
     const {
   std::string designator;
-  for (const auto &node : componentPath_) {
-    designator += "%"s + DEREF(node.component()).name().ToString();
+  for (const Symbol &component : GetComponentPath()) {
+    designator += "%"s + component.name().ToString();
   }
   return designator;
 }
@@ -1396,16 +1406,29 @@ UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
 }
 
 PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
-    const DerivedTypeSpec &derived) {
+    const DerivedTypeSpec &derived, bool ignoreCoarrays) {
   PotentialComponentIterator potentials{derived};
-  return std::find_if(
-      potentials.begin(), potentials.end(), [](const Symbol &component) {
-        if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
-          const DeclTypeSpec *type{details->type()};
-          return type && IsEventTypeOrLockType(type->AsDerived());
+  auto iter{potentials.begin()};
+  for (auto end{potentials.end()}; iter != end; ++iter) {
+    const Symbol &component{*iter};
+    if (const auto *object{component.detailsIf<ObjectEntityDetails>()}) {
+      if (const DeclTypeSpec * type{object->type()}) {
+        if (IsEventTypeOrLockType(type->AsDerived())) {
+          if (!ignoreCoarrays) {
+            break; // found one
+          }
+          auto path{iter.GetComponentPath()};
+          path.pop_back();
+          if (std::find_if(path.begin(), path.end(), [](const Symbol &sym) {
+                return evaluate::IsCoarray(sym);
+              }) == path.end()) {
+            break; // found one not in a coarray
+          }
         }
-        return false;
-      });
+      }
+    }
+  }
+  return iter;
 }
 
 UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(

flang/test/Semantics/call04.f90

@@ -56,11 +56,11 @@ subroutine s05(x) ! C846
 subroutine s06(x) ! C847
   use ISO_FORTRAN_ENV, only: lock_type
   !ERROR: An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE
-  type(lock_type), intent(out) :: x
+  type(lock_type), intent(out) :: x[*]
 end subroutine
 
 subroutine s07(x) ! C847
   use ISO_FORTRAN_ENV, only: event_type
   !ERROR: An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE
-  type(event_type), intent(out) :: x
+  type(event_type), intent(out) :: x[*]
 end subroutine

flang/test/Semantics/critical02.f90

@@ -82,7 +82,7 @@ end subroutine test8
 
 subroutine test9()
   use iso_fortran_env
-  type(lock_type) :: l
+  type(lock_type), save :: l[*]
 
   critical
     !ERROR: An image control statement is not allowed in a CRITICAL construct

flang/test/Semantics/doconcurrent01.f90

@@ -97,7 +97,7 @@ end subroutine s3
 
 subroutine s4()
   use iso_fortran_env
-  type(lock_type) :: l
+  type(lock_type), save :: l[*]
 
   do concurrent (i = 1:n)
 !ERROR: An image control statement is not allowed in DO CONCURRENT

flang/test/Semantics/event01b.f90

@@ -10,8 +10,41 @@ program test_event_post
   implicit none
 
   ! event_type variables must be coarrays
+  !ERROR: Variable 'non_coarray' with EVENT_TYPE or LOCK_TYPE must be a coarray
   type(event_type) non_coarray
 
+  ! event_type potential object components must be nested in coarrays
+  type :: has_event
+    type(event_type) event
+  end type
+  type :: bad1
+    type(has_event) component
+  end type
+  type :: bad2
+    type(has_event), allocatable :: component
+  end type
+  type :: good1
+    type(has_event), pointer :: component
+  end type
+  type :: good2
+    type(has_event), allocatable :: component[:]
+  end type
+  !ERROR: Variable 'non_coarray_component1' with EVENT_TYPE or LOCK_TYPE potential component '%event' must be a coarray
+  type(has_event) non_coarray_component1
+  !ERROR: Variable 'non_coarray_component2' with EVENT_TYPE or LOCK_TYPE potential component '%component%event' must be a coarray
+  type(bad1) non_coarray_component2
+  !ERROR: Variable 'non_coarray_component3' with EVENT_TYPE or LOCK_TYPE potential component '%component%event' must be a coarray
+  type(bad2) non_coarray_component3
+  ! these are okay
+  type(has_event) ok_non_coarray_component1[*]
+  type(has_event), pointer :: ok_non_coarray_component2
+  type(bad1) :: ok_non_coarray_component3[*]
+  type(bad1), pointer :: ok_non_coarray_component4
+  type(bad2) :: ok_non_coarray_component5[*]
+  type(bad2), pointer :: ok_non_coarray_component6
+  type(good1) ok_non_coarray_component7
+  type(good2) ok_non_coarray_component8
+
   type(event_type) concert[*], occurrences(2)[*]
   integer non_event[*], sync_status, co_indexed_integer[*], superfluous_stat, non_scalar(1)
   character(len=128) error_message, co_indexed_character[*], superfluous_errmsg
@@ -25,10 +58,6 @@ program test_event_post
   !ERROR: The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV
   event post(non_event)
 
-  ! event-variable must be a coarray
-  !ERROR: The event-variable must be a coarray
-  event post(non_coarray)
-
   !ERROR: Must be a scalar value, but is a rank-1 array
   event post(occurrences)
 

flang/test/Semantics/event02b.f90

@@ -10,6 +10,7 @@ program test_event_wait
   implicit none
 
   ! event_type variables must be coarrays
+  !ERROR: Variable 'non_coarray' with EVENT_TYPE or LOCK_TYPE must be a coarray
   type(event_type) non_coarray
 
   type(event_type) concert[*], occurrences(2)[*]
@@ -24,9 +25,6 @@ program test_event_wait
   !ERROR: The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV
   event wait(non_event)
 
-  !ERROR: The event-variable must be a coarray
-  event wait(non_coarray)
-
   !ERROR: A event-variable in a EVENT WAIT statement may not be a coindexed object
   event wait(concert[1])
 

flang/test/Semantics/sync-stat-list.f90

@@ -16,7 +16,7 @@ program test_sync_stat_list
   character(len=128) error_message, superfluous_errmsg, coindexed_character[*]
   logical invalid_type
   type(team_type) :: home
-  type(lock_type) :: latch
+  type(lock_type) :: latch[*]
 
   ! valid
   change team (home, stat=sync_status, errmsg=error_message)