[flang-commits] [flang] 3e3855b - [flang] Don't flag CLASS(*) ASSOCIATED() pointer or target as error (#125890)

[via flang-commits]

Author: Peter Klausler
Date: 2025-02-27T14:28:34-08:00
New Revision: 3e3855b0e553e66cde5ad9a55c078c9650798e4a

URL: https://github.com/llvm/llvm-project/commit/3e3855b0e553e66cde5ad9a55c078c9650798e4a
DIFF: https://github.com/llvm/llvm-project/commit/3e3855b0e553e66cde5ad9a55c078c9650798e4a.diff

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

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 https://github.com/llvm/llvm-project/issues/125774.

Added: 
    flang/test/Semantics/bug125774.f90

Modified: 
    flang/lib/Semantics/check-call.cpp

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 93ae05e2902f0..5287c4f27005c 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -1483,6 +1483,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
@@ -1589,7 +1591,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 0000000000000..9844f1ec5eb1e
--- /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