[flang] Dig deeper to find more EVENT_TYPE/LOCK_TYPE misuse

[klausler]

Only objects may have these types, or have potential subobject components with these types.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

Only objects may have these types, or have potential subobject components with these types.

---

Full diff: https://github.com/llvm/llvm-project/pull/130687.diff

2 Files Affected:

• (modified) flang/lib/Semantics/check-declarations.cpp (+14)
• (modified) flang/test/Semantics/event02b.f90 (+14)

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index e5a01657e4a15..4d20d4670a9ac 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -3717,6 +3717,20 @@ void CheckHelper::CheckSymbolType(const Symbol &symbol) {
           "'%s' has a type %s with a deferred type parameter but is neither an allocatable nor an object pointer"_err_en_US,
           symbol.name(), dyType->AsFortran());
     }
+    if (!symbol.has<ObjectEntityDetails>()) {
+      if (const DerivedTypeSpec *
+          derived{evaluate::GetDerivedTypeSpec(*dyType)}) {
+        if (IsEventTypeOrLockType(derived)) {
+          messages_.Say(
+              "Entity '%s' with EVENT_TYPE or LOCK_TYPE must be an object"_err_en_US,
+              symbol.name());
+        } else if (auto iter{FindEventOrLockPotentialComponent(*derived)}) {
+          messages_.Say(
+              "Entity '%s' with EVENT_TYPE or LOCK_TYPE potential subobject component '%s' must be an object"_err_en_US,
+              symbol.name(), iter.BuildResultDesignatorName());
+        }
+      }
+    }
   }
 }
 
diff --git a/flang/test/Semantics/event02b.f90 b/flang/test/Semantics/event02b.f90
index 94971022878ac..0cf8c70b78415 100644
--- a/flang/test/Semantics/event02b.f90
+++ b/flang/test/Semantics/event02b.f90
@@ -18,6 +18,20 @@ program test_event_wait
   character(len=128) error_message, non_scalar_char(1), co_indexed_character[*], superfluous_errmsg
   logical invalid_type
 
+  type t
+    type(event_type) event
+  end type
+  !ERROR: Entity 'badfunc0' with EVENT_TYPE or LOCK_TYPE must be an object
+  procedure(type(event_type)) :: badfunc0
+  !ERROR: Entity 'badfunc1' with EVENT_TYPE or LOCK_TYPE must be an object
+  procedure(type(event_type)), pointer :: badfunc1
+  !ERROR: Entity 'badfunc2' with EVENT_TYPE or LOCK_TYPE potential subobject component '%event' must be an object
+  procedure(type(t)) badfunc2
+  !ERROR: Entity 'badfunc3' with EVENT_TYPE or LOCK_TYPE must be an object
+  type(event_type), external :: badfunc3
+  !ERROR: Entity 'badfunc4' with EVENT_TYPE or LOCK_TYPE potential subobject component '%event' must be an object
+  type(t), external :: badfunc4
+
   !____________________ non-standard-conforming statements __________________________
 
   !_________________________ invalid event-variable ________________________________