[flang-commits] [flang] a7802a8 - [flang] Do not return true for pointer sub-object in IsPointerObject
Jean Perier via flang-commits
flang-commits at lists.llvm.org
Fri Mar 11 00:26:51 PST 2022
Author: Jean Perier
Date: 2022-03-11T09:26:21+01:00
New Revision: a7802a806d5f8dea2038507f4746b661d4e9bf97
URL: https://github.com/llvm/llvm-project/commit/a7802a806d5f8dea2038507f4746b661d4e9bf97
DIFF: https://github.com/llvm/llvm-project/commit/a7802a806d5f8dea2038507f4746b661d4e9bf97.diff
LOG: [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
Added:
Modified:
flang/lib/Evaluate/tools.cpp
flang/lib/Semantics/check-call.cpp
flang/test/Semantics/call03.f90
flang/test/Semantics/call07.f90
Removed:
################################################################################
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 965e5d43c8b20..48c638bcb9337 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/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;
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 45a83fe710983..3f39e064e6d6e 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/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() &&
diff --git a/flang/test/Semantics/call03.f90 b/flang/test/Semantics/call03.f90
index e89bce7ae0894..24e7e40264e78 100644
--- a/flang/test/Semantics/call03.f90
+++ b/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
diff --git a/flang/test/Semantics/call07.f90 b/flang/test/Semantics/call07.f90
index db5e0a6914597..673648979ab55 100644
--- a/flang/test/Semantics/call07.f90
+++ b/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
More information about the flang-commits
mailing list