[flang] Don't flag CLASS(*) ASSOCIATED() pointer or target as error

[klausler]

As I read the standard, an unlimited polymorphic pointer or target should be viewed as compatible with any data target or data pointer when used in the two-argument form of the intrinsic function ASSOCIATED().

Fixes #125774.

[llvmbot]

@llvm/pr-subscribers-flang-semantics

Author: Peter Klausler (klausler)

Changes

As I read the standard, an unlimited polymorphic pointer or target should be viewed as compatible with any data target or data pointer when used in the two-argument form of the intrinsic function ASSOCIATED().

Fixes #125774.

---

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

2 Files Affected:

• (modified) flang/lib/Semantics/check-call.cpp (+4-1)
• (added) flang/test/Semantics/bug125774.f90 (+15)

diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index e396ece3031039..624a8e1a34ee5b 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1478,6 +1478,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
       }
       if (const auto &targetArg{arguments[1]}) {
         // The standard requires that the TARGET= argument, when present,
+        // be type compatible with the POINTER= for a data pointer.  In
+        // the case of procedure pointers, the standard requires that it
         // be a valid RHS for a pointer assignment that has the POINTER=
         // argument as its LHS.  Some popular compilers misinterpret this
         // requirement more strongly than necessary, and actually validate
@@ -1584,7 +1586,8 @@ static void CheckAssociated(evaluate::ActualArguments &arguments,
             }
             if (const auto pointerType{pointerArg->GetType()}) {
               if (const auto targetType{targetArg->GetType()}) {
-                ok = pointerType->IsTkCompatibleWith(*targetType);
+                ok = pointerType->IsTkCompatibleWith(*targetType) ||
+                    targetType->IsTkCompatibleWith(*pointerType);
               }
             }
           } else {
diff --git a/flang/test/Semantics/bug125774.f90 b/flang/test/Semantics/bug125774.f90
new file mode 100644
index 00000000000000..9844f1ec5eb1eb
--- /dev/null
+++ b/flang/test/Semantics/bug125774.f90
@@ -0,0 +1,15 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+type t
+end type
+real, pointer :: rptr
+type(t), pointer :: tptr
+class(*), pointer :: ulpp
+print *, associated(rptr, ulpp)
+print *, associated(ulpp, rptr)
+print *, associated(tptr, ulpp)
+print *, associated(ulpp, tptr)
+!ERROR: Arguments of ASSOCIATED() must be a pointer and an optional valid target
+print *, associated(rptr, tptr)
+!ERROR: Arguments of ASSOCIATED() must be a pointer and an optional valid target
+print *, associated(tptr, rptr)
+end

[DanielCChen]

LGTM.
Thanks for the quick fix!