diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h index 16fd8d158b0e0..21c460e5ff346 100644 --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -47,10 +47,6 @@ const Scope *FindModuleFileContaining(const Scope &); const Scope *FindPureProcedureContaining(const Scope &); const Scope *FindOpenACCConstructContaining(const Scope *); -const Symbol *FindPointerComponent(const Scope &); -const Symbol *FindPointerComponent(const DerivedTypeSpec &); -const Symbol *FindPointerComponent(const DeclTypeSpec &); -const Symbol *FindPointerComponent(const Symbol &); const Symbol *FindInterface(const Symbol &); const Symbol *FindSubprogram(const Symbol &); const Symbol *FindOverriddenBinding( @@ -633,6 +629,8 @@ PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent( const DerivedTypeSpec &, bool ignoreCoarrays = false); PotentialComponentIterator::const_iterator FindCoarrayPotentialComponent( const DerivedTypeSpec &); +PotentialAndPointerComponentIterator::const_iterator +FindPointerPotentialComponent(const DerivedTypeSpec &); UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent( const DerivedTypeSpec &); UltimateComponentIterator::const_iterator FindPointerUltimateComponent( diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp index 205b4a780258c..25cc2e9535a2f 100644 --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -444,7 +444,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, dummy.type.type().AsFortran()); } - bool actualIsCoindexed{ExtractCoarrayRef(actual).has_value()}; + auto actualCoarrayRef{ExtractCoarrayRef(actual)}; bool dummyIsAssumedSize{dummy.type.attrs().test( characteristics::TypeAndShape::Attr::AssumedSize)}; bool dummyIsAsynchronous{ @@ -455,7 +455,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, dummy.attrs.test(characteristics::DummyDataObject::Attr::Value)}; bool dummyIsPolymorphic{dummy.type.type().IsPolymorphic()}; if (actualIsPolymorphic && dummyIsPolymorphic && - actualIsCoindexed) { // 15.5.2.4(2) + actualCoarrayRef) { // 15.5.2.4(2) messages.Say( "Coindexed polymorphic object may not be associated with a polymorphic %s"_err_en_US, dummyName); @@ -499,7 +499,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, } } } - if (actualIsCoindexed) { + if (actualCoarrayRef) { if (dummy.intent != common::Intent::In && !dummyIsValue) { if (auto bad{FindAllocatableUltimateComponent( *actualDerived)}) { // 15.5.2.4(6) @@ -508,15 +508,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, bad.BuildResultDesignatorName(), dummyName); } } - if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537 - const Symbol &coarray{coarrayRef->GetLastSymbol()}; - if (const DeclTypeSpec * type{coarray.GetType()}) { - if (const DerivedTypeSpec * derived{type->AsDerived()}) { - if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) { - evaluate::SayWithDeclaration(messages, coarray, - "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US, - coarray.name(), bad.BuildResultDesignatorName(), dummyName); - } + const Symbol &coarray{actualCoarrayRef->GetLastSymbol()}; + if (const DeclTypeSpec * type{coarray.GetType()}) { // C1537 + if (const DerivedTypeSpec * derived{type->AsDerived()}) { + if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) { + evaluate::SayWithDeclaration(messages, coarray, + "Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US, + coarray.name(), bad.BuildResultDesignatorName(), dummyName); } } } @@ -557,7 +555,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, if (actualRank == 0 && !actualIsAssumedRank && !dummyIsAllocatableOrPointer) { // Actual is scalar, dummy is an array. F'2023 15.5.2.5p14 - if (actualIsCoindexed) { + if (actualCoarrayRef) { basicError = true; messages.Say( "Coindexed scalar actual argument must be associated with a scalar %s"_err_en_US, @@ -764,7 +762,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, dummy.attrs.test(characteristics::DummyDataObject::Attr::Contiguous)}; if ((actualIsAsynchronous || actualIsVolatile) && (dummyIsAsynchronous || dummyIsVolatile) && !dummyIsValue) { - if (actualIsCoindexed) { // C1538 + if (actualCoarrayRef) { // C1538 messages.Say( "Coindexed ASYNCHRONOUS or VOLATILE actual argument may not be associated with %s with ASYNCHRONOUS or VOLATILE attributes unless VALUE"_err_en_US, dummyName); @@ -785,12 +783,12 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, dummy.attrs.test(characteristics::DummyDataObject::Attr::Optional)}; if (dummyIsAllocatable) { if (actualIsAllocatable) { - if (actualIsCoindexed && dummy.intent != common::Intent::In) { + if (actualCoarrayRef && dummy.intent != common::Intent::In) { messages.Say( "ALLOCATABLE %s must have INTENT(IN) to be associated with a coindexed actual argument"_err_en_US, dummyName); } - if (!actualIsCoindexed && actualLastSymbol && dummy.type.corank() == 0 && + if (!actualCoarrayRef && actualLastSymbol && dummy.type.corank() == 0 && actualLastSymbol->Corank() > 0) { messages.Say( "ALLOCATABLE %s is not a coarray but actual argument has corank %d"_err_en_US, @@ -971,8 +969,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy, if (dummy.attrs.test(characteristics::DummyDataObject::Attr::Target) && context.ShouldWarn(common::UsageWarning::NonTargetPassedToTarget)) { bool actualIsVariable{evaluate::IsVariable(actual)}; - bool actualIsTemp{!actualIsVariable || HasVectorSubscript(actual) || - evaluate::ExtractCoarrayRef(actual)}; + bool actualIsTemp{ + !actualIsVariable || HasVectorSubscript(actual) || actualCoarrayRef}; if (actualIsTemp) { messages.Say(common::UsageWarning::NonTargetPassedToTarget, "Any pointer associated with TARGET %s during this call will not be associated with the value of '%s' afterwards"_warn_en_US, diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index 7b837930bf785..518b82df068f2 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2246,14 +2246,22 @@ MaybeExpr ExpressionAnalyzer::Analyze( } else if (IsNullAllocatable(&*value) && IsAllocatable(*symbol)) { result.Add(*symbol, Expr{NullPointer{}}); continue; - } else if (const Symbol * pointer{FindPointerComponent(*symbol)}; - pointer && pureContext) { // C1594(4) - if (const Symbol * - visible{semantics::FindExternallyVisibleObject( - *value, *pureContext)}) { - Say(expr.source, - "The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US, - visible->name(), symbol->name(), pointer->name()); + } else if (auto *derived{evaluate::GetDerivedTypeSpec( + evaluate::DynamicType::From(*symbol))}) { + if (auto iter{FindPointerPotentialComponent(*derived)}; + iter && pureContext) { // F'2023 C15104(4) + if (const Symbol * + visible{semantics::FindExternallyVisibleObject( + *value, *pureContext)}) { + Say(expr.source, + "The externally visible object '%s' may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US, + visible->name(), symbol->name(), + iter.BuildResultDesignatorName()); + } else if (ExtractCoarrayRef(*value)) { + Say(expr.source, + "A coindexed object may not be used in a pure procedure as the value for component '%s' which has the pointer component '%s'"_err_en_US, + symbol->name(), iter.BuildResultDesignatorName()); + } } } // Make implicit conversion explicit to allow folding of the structure diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp index 23a64d05338be..ab3771c808761 100644 --- a/flang/lib/Semantics/pointer-assignment.cpp +++ b/flang/lib/Semantics/pointer-assignment.cpp @@ -194,7 +194,7 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) { return true; } if (const auto *pureProc{FindPureProcedureContaining(scope_)}) { - if (pointerComponentLHS_) { // C1594(4) is a hard error + if (pointerComponentLHS_) { // F'2023 C15104(4) is a hard error if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) { if (auto *msg{Say( "Externally visible object '%s' may not be associated with pointer component '%s' in a pure procedure"_err_en_US, diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp index 5e58a0c75c77b..6867777bbcdc0 100644 --- a/flang/lib/Semantics/tools.cpp +++ b/flang/lib/Semantics/tools.cpp @@ -311,69 +311,6 @@ bool IsBindCProcedure(const Scope &scope) { } } -static const Symbol *FindPointerComponent( - const Scope &scope, std::set &visited) { - if (!scope.IsDerivedType()) { - return nullptr; - } - if (!visited.insert(&scope).second) { - return nullptr; - } - // If there's a top-level pointer component, return it for clearer error - // messaging. - for (const auto &pair : scope) { - const Symbol &symbol{*pair.second}; - if (IsPointer(symbol)) { - return &symbol; - } - } - for (const auto &pair : scope) { - const Symbol &symbol{*pair.second}; - if (const auto *details{symbol.detailsIf()}) { - if (const DeclTypeSpec * type{details->type()}) { - if (const DerivedTypeSpec * derived{type->AsDerived()}) { - if (const Scope * nested{derived->scope()}) { - if (const Symbol * - pointer{FindPointerComponent(*nested, visited)}) { - return pointer; - } - } - } - } - } - } - return nullptr; -} - -const Symbol *FindPointerComponent(const Scope &scope) { - std::set visited; - return FindPointerComponent(scope, visited); -} - -const Symbol *FindPointerComponent(const DerivedTypeSpec &derived) { - if (const Scope * scope{derived.scope()}) { - return FindPointerComponent(*scope); - } else { - return nullptr; - } -} - -const Symbol *FindPointerComponent(const DeclTypeSpec &type) { - if (const DerivedTypeSpec * derived{type.AsDerived()}) { - return FindPointerComponent(*derived); - } else { - return nullptr; - } -} - -const Symbol *FindPointerComponent(const DeclTypeSpec *type) { - return type ? FindPointerComponent(*type) : nullptr; -} - -const Symbol *FindPointerComponent(const Symbol &symbol) { - return IsPointer(symbol) ? &symbol : FindPointerComponent(symbol.GetType()); -} - // C1594 specifies several ways by which an object might be globally visible. const Symbol *FindExternallyVisibleObject( const Symbol &object, const Scope &scope, bool isPointerDefinition) { @@ -1393,6 +1330,12 @@ PotentialComponentIterator::const_iterator FindCoarrayPotentialComponent( [](const Symbol &symbol) { return evaluate::IsCoarray(symbol); }); } +PotentialAndPointerComponentIterator::const_iterator +FindPointerPotentialComponent(const DerivedTypeSpec &derived) { + PotentialAndPointerComponentIterator potentials{derived}; + return std::find_if(potentials.begin(), potentials.end(), IsPointer); +} + UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent( const DerivedTypeSpec &derived) { UltimateComponentIterator ultimates{derived}; diff --git a/flang/test/Semantics/structconst03.f90 b/flang/test/Semantics/structconst03.f90 index 7940ada944668..ecd31723b12bb 100644 --- a/flang/test/Semantics/structconst03.f90 +++ b/flang/test/Semantics/structconst03.f90 @@ -49,7 +49,7 @@ module module1 contains - pure subroutine ps1(dummy1, dummy2, dummy3, dummy4) + pure subroutine ps1(dummy1, dummy2, dummy3, dummy4, co2, co3, co4) real, target :: local1 type(t1(0)) :: x1 type(t2(0)) :: x2 @@ -61,6 +61,9 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4) real, intent(inout), target :: dummy4[*] real, target :: commonvar1 common /cblock/ commonvar1 + type(has_pointer1), intent(in out) :: co2[*] + type(has_pointer2), intent(in out) :: co3[*] + type(has_pointer3), intent(in out) :: co4[*] x1 = t1(0)(local1) !ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure x1 = t1(0)(usedfrom1) @@ -82,14 +85,20 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4) x3 = t3(0)(has_pointer2(has_pointer1(modulevar1))) !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure x4 = t4(0)(has_pointer3(has_pointer1(modulevar1))) - !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop' x2 = t2(0)(modulevar2) - !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop' x3 = t3(0)(modulevar3) - !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop' x4 = t4(0)(modulevar4) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop' + x2 = t2(0)(co2[1]) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop' + x3 = t3(0)(co3[1]) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop' + x4 = t4(0)(co4[1]) contains - pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a) + pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a, co2a, co3a, co4a) real, target :: local1a type(t1(0)) :: x1a type(t2(0)) :: x2a @@ -99,6 +108,9 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a) real, intent(inout), target :: dummy2a real, pointer :: dummy3a real, intent(inout), target :: dummy4a[*] + type(has_pointer1), intent(in out) :: co2a[*] + type(has_pointer2), intent(in out) :: co3a[*] + type(has_pointer3), intent(in out) :: co4a[*] x1a = t1(0)(local1a) !ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure x1a = t1(0)(usedfrom1) @@ -123,12 +135,18 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a) x3a = t3(0)(has_pointer2(has_pointer1(modulevar1))) !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure x4a = t4(0)(has_pointer3(has_pointer1(modulevar1))) - !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop' x2a = t2(0)(modulevar2) - !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop' x3a = t3(0)(modulevar3) - !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop' x4a = t4(0)(modulevar4) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop' + x2a = t2(0)(co2a[1]) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop' + x3a = t3(0)(co3a[1]) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop' + x4a = t4(0)(co4a[1]) end subroutine subr end subroutine diff --git a/flang/test/Semantics/structconst04.f90 b/flang/test/Semantics/structconst04.f90 index f19852b95a607..abddf6001726c 100644 --- a/flang/test/Semantics/structconst04.f90 +++ b/flang/test/Semantics/structconst04.f90 @@ -44,7 +44,7 @@ module module1 contains - pure subroutine ps1(dummy1, dummy2, dummy3, dummy4) + pure subroutine ps1(dummy1, dummy2, dummy3, dummy4, co2, co3, co4) real, target :: local1 type(t1) :: x1 type(t2) :: x2 @@ -56,6 +56,9 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4) real, intent(inout), target :: dummy4[*] real, target :: commonvar1 common /cblock/ commonvar1 + type(has_pointer1), intent(in out) :: co2[*] + type(has_pointer2), intent(in out) :: co3[*] + type(has_pointer3), intent(in out) :: co4[*] x1 = t1(local1) !ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure x1 = t1(usedfrom1) @@ -77,14 +80,20 @@ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4) x3 = t3(has_pointer2(has_pointer1(modulevar1))) !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure x4 = t4(has_pointer3(has_pointer1(modulevar1))) - !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop' x2 = t2(modulevar2) - !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop' x3 = t3(modulevar3) - !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop' x4 = t4(modulevar4) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop' + x2 = t2(co2[1]) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop' + x3 = t3(co3[1]) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop' + x4 = t4(co4[1]) contains - pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a) + pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a, co2a, co3a, co4a) real, target :: local1a type(t1) :: x1a type(t2) :: x2a @@ -94,6 +103,9 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a) real, intent(inout), target :: dummy2a real, pointer :: dummy3a real, intent(inout), target :: dummy4a[*] + type(has_pointer1), intent(in out) :: co2a[*] + type(has_pointer2), intent(in out) :: co3a[*] + type(has_pointer3), intent(in out) :: co4a[*] x1a = t1(local1a) !ERROR: Externally visible object 'usedfrom1' may not be associated with pointer component 'pt1' in a pure procedure x1a = t1(usedfrom1) @@ -118,12 +130,18 @@ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a) x3a = t3(has_pointer2(has_pointer1(modulevar1))) !ERROR: Externally visible object 'modulevar1' may not be associated with pointer component 'ptop' in a pure procedure x4a = t4(has_pointer3(has_pointer1(modulevar1))) - !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar2' may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop' x2a = t2(modulevar2) - !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar3' may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop' x3a = t3(modulevar3) - !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component 'ptop' + !ERROR: The externally visible object 'modulevar4' may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop' x4a = t4(modulevar4) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp1' which has the pointer component '%ptop' + x2a = t2(co2a[1]) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp2' which has the pointer component '%pnested%ptop' + x3a = t3(co3a[1]) + !ERROR: A coindexed object may not be used in a pure procedure as the value for component 'hp3' which has the pointer component '%has_pointer2%pnested%ptop' + x4a = t4(co4a[1]) end subroutine subr end subroutine