[flang-commits] [flang] 82dbe82 - [flang] Refine pointer/target test for ASSOCIATED intrinsic

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2022-02-10T11:32:21-08:00
New Revision: 82dbe82585fbb33c8c65a1cae10b6f2bbede9bc8

URL: https://github.com/llvm/llvm-project/commit/82dbe82585fbb33c8c65a1cae10b6f2bbede9bc8
DIFF: https://github.com/llvm/llvm-project/commit/82dbe82585fbb33c8c65a1cae10b6f2bbede9bc8.diff

LOG: [flang] Refine pointer/target test for ASSOCIATED intrinsic

The second argument to the ASSOCIATED intrinsic must be a valid pointer
or target. The test for this property only checked the last symbol
in a data-reference, but any symbol in the reference with the
POINTER or TARGET attribute will do.

Differential Revision: https://reviews.llvm.org/D119450

Added: 
    

Modified: 
    flang/lib/Evaluate/intrinsics.cpp
    flang/test/Semantics/associated.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 3fb5d67a7b4ad..72563a62c3064 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2260,22 +2260,18 @@ static bool CheckAssociated(SpecificCall &call, FoldingContext &context) {
                         "procedure designator"_err_en_US,
                         pointerSymbol->name(), targetName),
                     *pointerSymbol);
-              } else {
+              } else if (targetSymbol) {
                 // object pointer and target
-                if (const Symbol * targetSymbol{GetLastSymbol(*targetExpr)}) {
-                  if (!(targetSymbol->attrs().test(semantics::Attr::POINTER) ||
-                          targetSymbol->attrs().test(
-                              semantics::Attr::TARGET))) {
-                    AttachDeclaration(
-                        context.messages().Say(
-                            "TARGET= argument '%s' must have either "
-                            "the POINTER or the TARGET "
-                            "attribute"_err_en_US,
-                            targetName),
-                        *targetSymbol);
+                SymbolVector symbols{GetSymbolVector(*targetExpr)};
+                CHECK(!symbols.empty());
+                if (!GetLastTarget(symbols)) {
+                  parser::Message *msg{context.messages().Say(
+                      "TARGET= argument '%s' must have either the POINTER or the TARGET attribute"_err_en_US,
+                      targetExpr->AsFortran())};
+                  for (SymbolRef ref : symbols) {
+                    msg = AttachDeclaration(msg, *ref);
                   }
                 }
-
                 if (const auto pointerType{pointerArg->GetType()}) {
                   if (const auto targetType{targetArg->GetType()}) {
                     ok = pointerType->IsTkCompatibleWith(*targetType);

diff  --git a/flang/test/Semantics/associated.f90 b/flang/test/Semantics/associated.f90
index 08dfa4530138b..3d472bdc06667 100644
--- a/flang/test/Semantics/associated.f90
+++ b/flang/test/Semantics/associated.f90
@@ -12,6 +12,14 @@ integer function abstractIntFunc(x)
     end function
   end interface
 
+  type :: t1
+    integer :: n
+  end type t1
+  type :: t2
+    type(t1) :: t1arr(2)
+    type(t1), pointer :: t1ptr(:)
+  end type t2
+
   contains
   integer function intFunc(x)
     integer, intent(in) :: x
@@ -60,6 +68,10 @@ subroutine test()
     procedure(subrInt), pointer :: subProcPointer
     procedure(), pointer :: implicitProcPointer
     logical :: lVar
+    type(t1) :: t1x
+    type(t1), target :: t1xtarget
+    type(t2) :: t2x
+    type(t2), target :: t2xtarget
 
     !ERROR: missing mandatory 'pointer=' argument
     lVar = associated()
@@ -91,6 +103,15 @@ subroutine test()
     !ERROR: TARGET= argument 'intvar' must have either the POINTER or the TARGET attribute
     lVar = associated(intPointerVar1, intVar)
 
+    !ERROR: TARGET= argument 't1x%n' must have either the POINTER or the TARGET attribute
+    lVar = associated(intPointerVar1, t1x%n)
+    lVar = associated(intPointerVar1, t1xtarget%n) ! ok
+    !ERROR: TARGET= argument 't2x%t1arr(1_8)%n' must have either the POINTER or the TARGET attribute
+    lVar = associated(intPointerVar1, t2x%t1arr(1)%n)
+    lVar = associated(intPointerVar1, t2x%t1ptr(1)%n) ! ok
+    lVar = associated(intPointerVar1, t2xtarget%t1arr(1)%n) ! ok
+    lVar = associated(intPointerVar1, t2xtarget%t1ptr(1)%n) ! ok
+
     ! Procedure pointer tests
     intprocPointer1 => intProc !OK
     lVar = associated(intprocPointer1, intProc) !OK