[flang-commits] [PATCH] D119450: [flang] Refine pointer/target test for ASSOCIATED intrinsic

[Peter Klausler via Phabricator via flang-commits]

klausler created this revision.
klausler added a reviewer: PeteSteinfeld.
klausler added a project: Flang.
Herald added a subscriber: jdoerfert.
klausler requested review of this revision.

The predicate IsInitialDataTarget() was failing to return a correct true
result in the case of a reference to the intrinsic function NULL() with a
MOLD= argument.  Fix, and improve tests for "NULL()" elsewhere in semantics,
checking for an attribute set by intrinsics.cpp rather than the actual name.


https://reviews.llvm.org/D119450

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


Index: flang/test/Semantics/associated.f90
===================================================================
--- flang/test/Semantics/associated.f90
+++ flang/test/Semantics/associated.f90
@@ -12,6 +12,14 @@
     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 @@
     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 @@
     !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
Index: flang/lib/Evaluate/intrinsics.cpp
===================================================================
--- flang/lib/Evaluate/intrinsics.cpp
+++ flang/lib/Evaluate/intrinsics.cpp
@@ -2260,22 +2260,18 @@
                         "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);


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D119450.407559.patch
Type: text/x-patch
Size: 3469 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20220210/8113bc8a/attachment-0001.bin>