diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 11928860fea5f..2b1881868b8b3 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -754,12 +754,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } - // Cases when temporaries might be needed but must not be permitted. + bool dummyIsContiguous{ + dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}; bool actualIsContiguous{IsSimplyContiguous(actual, foldingContext)}; + + // Cases when temporaries might be needed but must not be permitted. bool dummyIsAssumedShape{dummy.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedShape)}; - bool dummyIsContiguous{ - dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}; if ((actualIsAsynchronous || actualIsVolatile) && (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) { if (actualCoarrayRef) { // C1538 @@ -834,7 +835,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, if (scope) { semantics::CheckPointerAssignment(context, messages.at(), dummyName, dummy, actual, *scope, - /*isAssumedRank=*/dummyIsAssumedRank); + /*isAssumedRank=*/dummyIsAssumedRank, actualIsPointer); } } else if (!actualIsPointer) { messages.Say( diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index 36c9c5b845706..18a61af8c56f3 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -59,6 +59,7 @@ class PointerAssignmentChecker { PointerAssignmentChecker &set_isBoundsRemapping(bool); PointerAssignmentChecker &set_isAssumedRank(bool); PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *); + PointerAssignmentChecker &set_isRHSPointerActualArgument(bool); bool CheckLeftHandSide(const SomeExpr &); bool Check(const SomeExpr &); @@ -94,6 +95,7 @@ class PointerAssignmentChecker { bool isVolatile_{false}; bool isBoundsRemapping_{false}; bool isAssumedRank_{false}; + bool isRHSPointerActualArgument_{false}; const Symbol *pointerComponentLHS_{nullptr}; }; @@ -133,6 +135,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS( return *this; } +PointerAssignmentChecker & +PointerAssignmentChecker::set_isRHSPointerActualArgument(bool isPointerActual) { + isRHSPointerActualArgument_ = isPointerActual; + return *this; +} + bool PointerAssignmentChecker::CharacterizeProcedure() { if (!characterizedProcedure_) { characterizedProcedure_ = true; @@ -221,6 +229,9 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) { Say("CONTIGUOUS pointer may not be associated with a discontiguous target"_err_en_US); return false; } + } else if (isRHSPointerActualArgument_) { + Say("CONTIGUOUS pointer dummy argument may not be associated with non-CONTIGUOUS pointer actual argument"_err_en_US); + return false; } else { Warn(common::UsageWarning::PointerToPossibleNoncontiguous, "Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US); @@ -585,12 +596,14 @@ bool CheckStructConstructorPointerComponent(SemanticsContext &context, bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source, const std::string &description, const DummyDataObject &lhs, - const SomeExpr &rhs, const Scope &scope, bool isAssumedRank) { + const SomeExpr &rhs, const Scope &scope, bool isAssumedRank, + bool isPointerActualArgument) { 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) + .set_isRHSPointerActualArgument(isPointerActualArgument) .Check(rhs); } diff --git a/flang/lib/Semantics/pointer-assignment.h b/flang/lib/Semantics/pointer-assignment.h index 269d64112fd29..ad7c6554d5a13 100644 --- a/flang/lib/Semantics/pointer-assignment.h +++ b/flang/lib/Semantics/pointer-assignment.h @@ -31,7 +31,7 @@ bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs, bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source, const std::string &description, const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs, - const Scope &, bool isAssumedRank); + const Scope &, bool isAssumedRank, bool IsPointerActualArgument); bool CheckStructConstructorPointerComponent( SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &); diff --git a/flang/test/Semantics/call07.f90 b/flang/test/Semantics/call07.f90 index 3b5c2838fadf7..92f2bdba882d5 100644 --- a/flang/test/Semantics/call07.f90 +++ b/flang/test/Semantics/call07.f90 @@ -27,8 +27,10 @@ subroutine test !PORTABILITY: CONTIGUOUS entity 'scalar' should be an array pointer, assumed-shape, or assumed-rank real, contiguous :: scalar call s01(a03) ! ok - !WARNING: Target of CONTIGUOUS pointer association is not known to be contiguous + !ERROR: CONTIGUOUS pointer dummy argument may not be associated with non-CONTIGUOUS pointer actual argument call s01(a02) + !WARNING: Target of CONTIGUOUS pointer association is not known to be contiguous + call s01(a02(:)) !ERROR: CONTIGUOUS pointer may not be associated with a discontiguous target call s01(a03(::2)) call s02(a02) ! ok