[flang] Do not return true for pointer sub-object in IsPointerObject

evaluate::IsPointerObject used to return true for pointer suboject like
`pointer(10)` while these object are not pointers. This prevented some
checks like 15.5.2.7 to be correctly enforced (e.g., it was possible to
pass `pointer(10)` to a non intent(in) dummy pointer).

After updating IsPointerObject behavior and adding a test for 15.5.2.7 in
call07.f90, a test in call03.f90 for 15.5.2.4(14) was failing.
It appeared the related semantics check was relying on IsPointerObject
to return true for `pointer(10)`. Adapt the code to detect pointer element
in another way.
While looking at the code, I also noticed that semantics was
rejecting `character(1)` pointer/assumed shape suboject when these are
allowed (the standard has a special case for character(1) in
15.5.2.4(14), and I verified that other compilers that enforce 15.5.2.4(14)
do accept this).

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

Author: jeanPerier

flang/lib/Evaluate/tools.cpp

@@ -767,7 +767,7 @@ bool IsObjectPointer(const Expr<SomeType> &expr, FoldingContext &context) {
     return false;
   } else if (const auto *funcRef{UnwrapProcedureRef(expr)}) {
     return IsVariable(*funcRef);
-  } else if (const Symbol * symbol{GetLastSymbol(expr)}) {
+  } else if (const Symbol * symbol{UnwrapWholeSymbolOrComponentDataRef(expr)}) {
     return IsPointer(symbol->GetUltimate());
   } else {
     return false;

flang/lib/Semantics/check-call.cpp

@@ -309,29 +309,34 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
           "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US,
           dummyName);
     }
-    if (!IsArrayElement(actual) &&
-        !(actualType.type().category() == TypeCategory::Character &&
-            actualType.type().kind() == 1) &&
-        !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&
-        !dummyIsAssumedRank) {
-      messages.Say(
-          "Whole scalar actual argument may not be associated with a %s array"_err_en_US,
-          dummyName);
-    }
-    if (actualIsPolymorphic) {
-      messages.Say(
-          "Polymorphic scalar may not be associated with a %s array"_err_en_US,
-          dummyName);
-    }
-    if (actualIsPointer) {
-      messages.Say(
-          "Scalar POINTER target may not be associated with a %s array"_err_en_US,
-          dummyName);
-    }
-    if (actualLastSymbol && IsAssumedShape(*actualLastSymbol)) {
-      messages.Say(
-          "Element of assumed-shape array may not be associated with a %s array"_err_en_US,
-          dummyName);
+    bool actualIsArrayElement{IsArrayElement(actual)};
+    bool actualIsCKindCharacter{
+        actualType.type().category() == TypeCategory::Character &&
+        actualType.type().kind() == 1};
+    if (!actualIsCKindCharacter) {
+      if (!actualIsArrayElement &&
+          !(dummy.type.type().IsAssumedType() && dummyIsAssumedSize) &&
+          !dummyIsAssumedRank) {
+        messages.Say(
+            "Whole scalar actual argument may not be associated with a %s array"_err_en_US,
+            dummyName);
+      }
+      if (actualIsPolymorphic) {
+        messages.Say(
+            "Polymorphic scalar may not be associated with a %s array"_err_en_US,
+            dummyName);
+      }
+      if (actualIsArrayElement && actualLastSymbol &&
+          IsPointer(*actualLastSymbol)) {
+        messages.Say(
+            "Element of pointer array may not be associated with a %s array"_err_en_US,
+            dummyName);
+      }
+      if (actualLastSymbol && IsAssumedShape(*actualLastSymbol)) {
+        messages.Say(
+            "Element of assumed-shape array may not be associated with a %s array"_err_en_US,
+            dummyName);
+      }
     }
   }
   if (actualLastObject && actualLastObject->IsCoarray() &&

flang/test/Semantics/call03.f90

@@ -196,21 +196,28 @@ subroutine test08(x) ! 15.5.2.4(13)
   subroutine charray(x)
     character :: x(10)
   end subroutine
-  subroutine test09(ashape, polyarray, c) ! 15.5.2.4(14), 15.5.2.11
+  subroutine test09(ashape, polyarray, c, assumed_shape_char) ! 15.5.2.4(14), 15.5.2.11
     real :: x, arr(10)
     real, pointer :: p(:)
+    real, pointer :: p_scalar
+    character(10), pointer :: char_pointer(:)
+    character(*) :: assumed_shape_char(:)
     real :: ashape(:)
     class(t) :: polyarray(*)
     character(10) :: c(:)
     !ERROR: Whole scalar actual argument may not be associated with a dummy argument 'x=' array
     call assumedsize(x)
-    !ERROR: Scalar POINTER target may not be associated with a dummy argument 'x=' array
+    !ERROR: Whole scalar actual argument may not be associated with a dummy argument 'x=' array
+    call assumedsize(p_scalar)
+    !ERROR: Element of pointer array may not be associated with a dummy argument 'x=' array
     call assumedsize(p(1))
     !ERROR: Element of assumed-shape array may not be associated with a dummy argument 'x=' array
     call assumedsize(ashape(1))
     !ERROR: Polymorphic scalar may not be associated with a dummy argument 'x=' array
     call polyassumedsize(polyarray(1))
     call charray(c(1:1))  ! not an error if character
+    call charray(char_pointer(1))  ! not an error if character
+    call charray(assumed_shape_char(1))  ! not an error if character
     call assumedsize(arr(1))  ! not an error if element in sequence
     call assumedrank(x)  ! not an error
     call assumedtypeandsize(x)  ! not an error

flang/test/Semantics/call07.f90

@@ -14,6 +14,9 @@ subroutine s02(p)
   subroutine s03(p)
     real, pointer, intent(in) :: p(:)
   end subroutine
+  subroutine s04(p)
+    real, pointer :: p
+  end subroutine
 
   subroutine test
     !ERROR: CONTIGUOUS POINTER must be an array
@@ -30,6 +33,8 @@ subroutine test
     call s03(a03) ! ok
     !ERROR: Actual argument associated with POINTER dummy argument 'p=' must also be POINTER unless INTENT(IN)
     call s02(a03)
+    !ERROR: Actual argument associated with POINTER dummy argument 'p=' must also be POINTER unless INTENT(IN)
+    call s04(a02(1))
     !ERROR: An array section with a vector subscript may not be a pointer target
     call s03(a03([1,2,4]))
     !ERROR: A coindexed object may not be a pointer target