[flang-commits] [flang] f82ee15 - [flang] Don't check dummy vs. actual result rank for assumed-rank poi… (#66237)
via flang-commits
flang-commits at lists.llvm.org
Wed Sep 13 16:52:18 PDT 2023
Author: Peter Klausler
Date: 2023-09-13T16:52:15-07:00
New Revision: f82ee15554bfa9e8f2a26678caa25dbabb5fa220
URL: https://github.com/llvm/llvm-project/commit/f82ee15554bfa9e8f2a26678caa25dbabb5fa220
DIFF: https://github.com/llvm/llvm-project/commit/f82ee15554bfa9e8f2a26678caa25dbabb5fa220.diff
LOG: [flang] Don't check dummy vs. actual result rank for assumed-rank poi… (#66237)
…nters
When associating a function result pointer as an actual argument with a
dummy pointer that is assumed-rank, don't emit a bogus error.
Added:
flang/test/Semantics/call39.f90
Modified:
flang/lib/Semantics/check-call.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/data-to-inits.cpp
flang/lib/Semantics/pointer-assignment.cpp
flang/lib/Semantics/pointer-assignment.h
Removed:
################################################################################
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index c48c382218dc9bb..27abc9e2938af9f 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -329,10 +329,11 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
typesCompatible = true;
}
}
+ bool dummyIsAssumedRank{dummy.type.attrs().test(
+ characteristics::TypeAndShape::Attr::AssumedRank)};
if (typesCompatible) {
if (isElemental) {
- } else if (dummy.type.attrs().test(
- characteristics::TypeAndShape::Attr::AssumedRank)) {
+ } else if (dummyIsAssumedRank) {
} else if (dummy.ignoreTKR.test(common::IgnoreTKR::Rank)) {
} else if (dummyRank > 0 && !dummyIsAllocatableOrPointer &&
!dummy.type.attrs().test(
@@ -462,8 +463,6 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
: nullptr};
int actualRank{actualType.Rank()};
bool actualIsPointer{evaluate::IsObjectPointer(actual, foldingContext)};
- bool dummyIsAssumedRank{dummy.type.attrs().test(
- characteristics::TypeAndShape::Attr::AssumedRank)};
if (dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedShape)) {
// 15.5.2.4(16)
@@ -682,8 +681,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (dummyIsPointer) {
if (actualIsPointer || dummy.intent == common::Intent::In) {
if (scope) {
- semantics::CheckPointerAssignment(
- context, messages.at(), dummyName, dummy, actual, *scope);
+ semantics::CheckPointerAssignment(context, messages.at(), dummyName,
+ dummy, actual, *scope,
+ /*isAssumedRank=*/dummyIsAssumedRank);
}
} else if (!actualIsPointer) {
messages.Say(
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 612abc471c5c61f..52152fc19f55263 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -1067,7 +1067,8 @@ void CheckHelper::CheckPointerInitialization(const Symbol &symbol) {
SomeExpr lhs{evaluate::ProcedureDesignator{symbol}};
SomeExpr rhs{evaluate::ProcedureDesignator{**proc->init()}};
CheckPointerAssignment(context_, lhs, rhs,
- GetProgramUnitOrBlockConstructContaining(symbol));
+ GetProgramUnitOrBlockConstructContaining(symbol),
+ /*isBoundsRemapping=*/false, /*isAssumedRank=*/false);
}
}
}
diff --git a/flang/lib/Semantics/data-to-inits.cpp b/flang/lib/Semantics/data-to-inits.cpp
index 6fbe044aa4618d4..bc0355a2c597a6f 100644
--- a/flang/lib/Semantics/data-to-inits.cpp
+++ b/flang/lib/Semantics/data-to-inits.cpp
@@ -384,8 +384,9 @@ bool DataInitializationCompiler<DSV>::InitElement(
return true;
} else if (isProcPointer) {
if (evaluate::IsProcedure(*expr)) {
- if (CheckPointerAssignment(
- exprAnalyzer_.context(), designator, *expr, DEREF(scope_))) {
+ if (CheckPointerAssignment(exprAnalyzer_.context(), designator, *expr,
+ DEREF(scope_),
+ /*isBoundsRemapping=*/false, /*isAssumedRank=*/false)) {
if (lastSymbol->has<ProcEntityDetails>()) {
GetImage().AddPointer(offsetSymbol.offset(), *expr);
return true;
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index e75e9366942115d..8f01a3d7057e196 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -56,6 +56,7 @@ class PointerAssignmentChecker {
PointerAssignmentChecker &set_isContiguous(bool);
PointerAssignmentChecker &set_isVolatile(bool);
PointerAssignmentChecker &set_isBoundsRemapping(bool);
+ PointerAssignmentChecker &set_isAssumedRank(bool);
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
bool CheckLeftHandSide(const SomeExpr &);
bool Check(const SomeExpr &);
@@ -88,6 +89,7 @@ class PointerAssignmentChecker {
bool isContiguous_{false};
bool isVolatile_{false};
bool isBoundsRemapping_{false};
+ bool isAssumedRank_{false};
const Symbol *pointerComponentLHS_{nullptr};
};
@@ -115,6 +117,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isAssumedRank(
+ bool isAssumedRank) {
+ isAssumedRank_ = isAssumedRank;
+ return *this;
+}
+
PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS(
const Symbol *symbol) {
pointerComponentLHS_ = symbol;
@@ -263,7 +271,7 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
CHECK(frTypeAndShape);
if (!lhsType_->IsCompatibleWith(foldingContext_.messages(), *frTypeAndShape,
"pointer", "function result",
- isBoundsRemapping_ /*omit shape check*/,
+ /*omitShapeConformanceCheck=*/isBoundsRemapping_ || isAssumedRank_,
evaluate::CheckConformanceFlags::BothDeferredShape)) {
return false; // IsCompatibleWith() emitted message
}
@@ -489,17 +497,20 @@ static bool CheckPointerBounds(
bool CheckPointerAssignment(SemanticsContext &context,
const evaluate::Assignment &assignment, const Scope &scope) {
return CheckPointerAssignment(context, assignment.lhs, assignment.rhs, scope,
- CheckPointerBounds(context.foldingContext(), assignment));
+ CheckPointerBounds(context.foldingContext(), assignment),
+ /*isAssumedRank=*/false);
}
bool CheckPointerAssignment(SemanticsContext &context, const SomeExpr &lhs,
- const SomeExpr &rhs, const Scope &scope, bool isBoundsRemapping) {
+ const SomeExpr &rhs, const Scope &scope, bool isBoundsRemapping,
+ bool isAssumedRank) {
const Symbol *pointer{GetLastSymbol(lhs)};
if (!pointer) {
return false; // error was reported
}
PointerAssignmentChecker checker{context, scope, *pointer};
checker.set_isBoundsRemapping(isBoundsRemapping);
+ checker.set_isAssumedRank(isAssumedRank);
bool lhsOk{checker.CheckLeftHandSide(lhs)};
bool rhsOk{checker.Check(rhs)};
return lhsOk && rhsOk; // don't short-circuit
@@ -514,11 +525,12 @@ bool CheckStructConstructorPointerComponent(SemanticsContext &context,
bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
const std::string &description, const DummyDataObject &lhs,
- const SomeExpr &rhs, const Scope &scope) {
+ const SomeExpr &rhs, const Scope &scope, bool isAssumedRank) {
return PointerAssignmentChecker{context, scope, source, description}
.set_lhsType(common::Clone(lhs.type))
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
.set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
+ .set_isAssumedRank(isAssumedRank)
.Check(rhs);
}
@@ -526,7 +538,9 @@ bool CheckInitialDataPointerTarget(SemanticsContext &context,
const SomeExpr &pointer, const SomeExpr &init, const Scope &scope) {
return evaluate::IsInitialDataTarget(
init, &context.foldingContext().messages()) &&
- CheckPointerAssignment(context, pointer, init, scope);
+ CheckPointerAssignment(context, pointer, init, scope,
+ /*isBoundsRemapping=*/false,
+ /*isAssumedRank=*/false);
}
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/pointer-assignment.h b/flang/lib/Semantics/pointer-assignment.h
index 5ac258d03a0a264..269d64112fd29b6 100644
--- a/flang/lib/Semantics/pointer-assignment.h
+++ b/flang/lib/Semantics/pointer-assignment.h
@@ -26,11 +26,12 @@ class Symbol;
bool CheckPointerAssignment(
SemanticsContext &, const evaluate::Assignment &, const Scope &);
bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs,
- const SomeExpr &rhs, const Scope &, bool isBoundsRemapping = false);
+ const SomeExpr &rhs, const Scope &, bool isBoundsRemapping,
+ bool isAssumedRank);
bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source,
const std::string &description,
const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs,
- const Scope &);
+ const Scope &, bool isAssumedRank);
bool CheckStructConstructorPointerComponent(
SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
diff --git a/flang/test/Semantics/call39.f90 b/flang/test/Semantics/call39.f90
new file mode 100644
index 000000000000000..860ab0096401403
--- /dev/null
+++ b/flang/test/Semantics/call39.f90
@@ -0,0 +1,27 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic -Werror
+! Tests actual/dummy pointer argument shape mismatches
+module m
+ contains
+ subroutine s0(p)
+ real, pointer, intent(in) :: p
+ end
+ subroutine s1(p)
+ real, pointer, intent(in) :: p(:)
+ end
+ subroutine sa(p)
+ real, pointer, intent(in) :: p(..)
+ end
+ subroutine test
+ real, pointer :: a0, a1(:)
+ call s0(null(a0)) ! ok
+ !ERROR: Rank of dummy argument is 0, but actual argument has rank 1
+ !ERROR: Rank of pointer is 0, but function result has rank 1
+ call s0(null(a1))
+ !ERROR: Rank of dummy argument is 1, but actual argument has rank 0
+ !ERROR: Rank of pointer is 1, but function result has rank 0
+ call s1(null(a0))
+ call s1(null(a1)) ! ok
+ call sa(null(a0)) ! ok
+ call sa(null(a1)) ! ok
+ end
+end
More information about the flang-commits
mailing list