diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index c48c382218dc9..27abc9e2938af 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 612abc471c5c6..52152fc19f552 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 6fbe044aa4618..bc0355a2c597a 100644 --- a/flang/lib/Semantics/data-to-inits.cpp +++ b/flang/lib/Semantics/data-to-inits.cpp @@ -384,8 +384,9 @@ bool DataInitializationCompiler::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()) { GetImage().AddPointer(offsetSymbol.offset(), *expr); return true; diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index e75e936694211..8f01a3d7057e1 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 &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 5ac258d03a0a2..269d64112fd29 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 0000000000000..860ab00964014 --- /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