[flang-commits] [flang] [flang] Add the PROTECTED_TARGET attribute from the Fortran 2028 draft (PR #231341)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Mon Oct 12 17:47:44 PDT 2026
https://github.com/Saieiei created https://github.com/llvm/llvm-project/pull/231341
The Fortran 2028 draft J3/26-007r1 (8.5.16, 8.6.14) adds
PROTECTED_TARGET, an attribute for data pointers whose target cannot
be defined or deallocated through the pointer. Flang rejected it as
a syntax error.
Parse the attribute, the component attribute and the statement, and
add Attr::PROTECTED_TARGET so it is written to module files. Defining
the target through the pointer, a subobject, an associate name or a
function reference whose result has the attribute is an error (C866,
8.5.16 p2), as are violations of C781, C867 to C874 and C8109. C872
and C874 are not applied to intrinsic procedures. LASTPRIVATE checks
such a pointer as a pointer definition, since OpenMP updates it as
if by pointer assignment.
Three draft points needed a decision. C864 forbids a use-associated
nonpointer PROTECTED object as a data-target, but NOTE 1 shows
`p => x` as valid for a PROTECTED_TARGET pointer; this follows NOTE 1,
except that an initial-data-target keeps the optional
-Wpointer-to-undefinable warning. The attribute is not a characteristic
(15.3.2.2, 15.3.3), so interface compatibility ignores it. C870 to C874
apply to the pointer and its subobjects, not to associate names.
Assisted-by: GitHub Copilot
>From 1d2047f06d046dec1d9db3484c9fc4f95b9b88f5 Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Mon, 12 Oct 2026 19:47:32 -0500
Subject: [PATCH] [flang] Add the PROTECTED_TARGET attribute from the Fortran
2028 draft
The Fortran 2028 draft J3/26-007r1 (8.5.16, 8.6.14) adds
PROTECTED_TARGET, an attribute for data pointers whose target cannot
be defined or deallocated through the pointer. Flang rejected it as
a syntax error.
Parse the attribute, the component attribute and the statement, and
add Attr::PROTECTED_TARGET so it is written to module files. Defining
the target through the pointer, a subobject, an associate name or a
function reference whose result has the attribute is an error (C866,
8.5.16 p2), as are violations of C781, C867 to C874 and C8109. C872
and C874 are not applied to intrinsic procedures. LASTPRIVATE checks
such a pointer as a pointer definition, since OpenMP updates it as
if by pointer assignment.
Three draft points needed a decision. C864 forbids a use-associated
nonpointer PROTECTED object as a data-target, but NOTE 1 shows
`p => x` as valid for a PROTECTED_TARGET pointer; this follows NOTE 1,
except that an initial-data-target keeps the optional
-Wpointer-to-undefinable warning. The attribute is not a characteristic
(15.3.2.2, 15.3.3), so interface compatibility ignores it. C870 to C874
apply to the pointer and its subobjects, not to associate names.
Assisted-by: GitHub Copilot
---
flang/docs/ReleaseNotes.md | 9 +
.../include/flang/Evaluate/characteristics.h | 4 +
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 27 ++-
flang/include/flang/Semantics/attr.h | 4 +-
flang/lib/Evaluate/characteristics.cpp | 1 +
flang/lib/Parser/Fortran-parsers.cpp | 18 +-
flang/lib/Parser/program-parsers.cpp | 8 +-
flang/lib/Parser/unparse.cpp | 4 +
flang/lib/Semantics/check-allocate.cpp | 7 +
flang/lib/Semantics/check-call.cpp | 30 +++
flang/lib/Semantics/check-declarations.cpp | 10 +
flang/lib/Semantics/check-omp-structure.cpp | 12 +-
flang/lib/Semantics/definable.cpp | 125 ++++++++++++
flang/lib/Semantics/definable.h | 8 +
flang/lib/Semantics/pointer-assignment.cpp | 57 +++++-
flang/lib/Semantics/pointer-assignment.h | 2 +-
flang/lib/Semantics/resolve-names.cpp | 5 +
flang/test/Parser/protected-target.f90 | 47 +++++
.../OpenMP/lastprivate-protected-target.f90 | 15 ++
.../Semantics/modfile-protected-target.f90 | 30 +++
flang/test/Semantics/protected-target01.f90 | 143 ++++++++++++++
flang/test/Semantics/protected-target02.f90 | 182 ++++++++++++++++++
flang/test/Semantics/protected-target03.f90 | 80 ++++++++
flang/test/Semantics/protected-target04.f90 | 56 ++++++
25 files changed, 858 insertions(+), 28 deletions(-)
create mode 100644 flang/test/Parser/protected-target.f90
create mode 100644 flang/test/Semantics/OpenMP/lastprivate-protected-target.f90
create mode 100644 flang/test/Semantics/modfile-protected-target.f90
create mode 100644 flang/test/Semantics/protected-target01.f90
create mode 100644 flang/test/Semantics/protected-target02.f90
create mode 100644 flang/test/Semantics/protected-target03.f90
create mode 100644 flang/test/Semantics/protected-target04.f90
diff --git a/flang/docs/ReleaseNotes.md b/flang/docs/ReleaseNotes.md
index 609ca499da396..5fc2bfe248761 100644
--- a/flang/docs/ReleaseNotes.md
+++ b/flang/docs/ReleaseNotes.md
@@ -161,6 +161,15 @@ page](https://llvm.org/releases/).
## Windows Support
## Fortran Language Changes in Flang
+- The `PROTECTED_TARGET` attribute and statement from the Fortran 2028 working
+ draft (J3/26-007r1, 8.5.16 and 8.6.14) are now accepted. The target of a
+ `PROTECTED_TARGET` data pointer is not definable through that pointer, and
+ the constraints C781, C866 to C874 and C8109 are checked as errors (C872
+ and C874 for references to non-intrinsic procedures). As in 8.5.16 NOTE 1,
+ such a pointer may be pointer-assigned to a use-associated `PROTECTED`
+ target without a diagnostic, although C864 in the same draft still lists
+ that case. The attribute is not a procedure characteristic (15.3.2.2,
+ 15.3.3), so it does not affect interface compatibility.
- Standard intrinsic functions are now classified as `SIMPLE` (F2023 16.1 p2).
A procedure pointer or dummy procedure whose interface is an intrinsic
function, such as `procedure(sqrt)`, can no longer be associated with a
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 1ba0bf693c763..aacecbf1016fc 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -262,6 +262,10 @@ struct DummyDataObject {
Attrs attrs;
common::IgnoreTKRSet ignoreTKR;
std::optional<common::CUDADataAttr> cudaDataAttr;
+ // PROTECTED_TARGET is not a characteristic (F'2028 15.3.2.2), so it is kept
+ // apart from attrs and does not affect interface compatibility; C872 needs
+ // it.
+ bool isProtectedTarget{false};
};
// 15.3.2.3
diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h
index 7ca404663b486..dbd613c11ee18 100644
--- a/flang/include/flang/Parser/dump-parse-tree.h
+++ b/flang/include/flang/Parser/dump-parse-tree.h
@@ -878,6 +878,8 @@ class ParseTreeDumper {
NODE(parser, ProgramUnit)
NODE(parser, Protected)
NODE(parser, ProtectedStmt)
+ NODE(parser, ProtectedTarget)
+ NODE(parser, ProtectedTargetStmt)
NODE(parser, RankClause)
NODE(parser, ReadStmt)
NODE(parser, RealLiteralConstant)
diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index 207a5543ab775..294e1e3950799 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -173,6 +173,7 @@ struct ParameterStmt; // R851
struct OldParameterStmt;
struct PointerStmt; // R853
struct ProtectedStmt; // R855
+struct ProtectedTargetStmt; // F2028 R863
struct SaveStmt; // R856
struct TargetStmt; // R859
struct ValueStmt; // R861
@@ -372,8 +373,9 @@ EMPTY_CLASS(ErrorRecovery);
// access-stmt | allocatable-stmt | asynchronous-stmt | bind-stmt |
// codimension-stmt | contiguous-stmt | dimension-stmt | external-stmt |
// intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
-// pointer-stmt | protected-stmt | save-stmt | target-stmt |
-// volatile-stmt | value-stmt | common-stmt | equivalence-stmt
+// pointer-stmt | protected-stmt | protected-target-stmt | save-stmt |
+// target-stmt | volatile-stmt | value-stmt | common-stmt |
+// equivalence-stmt
// Extension: (Cray) based POINTER statement
// Extension: CUDA data attribute statement
struct OtherSpecificationStmt {
@@ -386,9 +388,10 @@ struct OtherSpecificationStmt {
common::Indirection<IntentStmt>, common::Indirection<IntrinsicStmt>,
common::Indirection<NamelistStmt>, common::Indirection<OptionalStmt>,
common::Indirection<PointerStmt>, common::Indirection<ProtectedStmt>,
- common::Indirection<SaveStmt>, common::Indirection<TargetStmt>,
- common::Indirection<ValueStmt>, common::Indirection<VolatileStmt>,
- common::Indirection<CommonStmt>, common::Indirection<EquivalenceStmt>,
+ common::Indirection<ProtectedTargetStmt>, common::Indirection<SaveStmt>,
+ common::Indirection<TargetStmt>, common::Indirection<ValueStmt>,
+ common::Indirection<VolatileStmt>, common::Indirection<CommonStmt>,
+ common::Indirection<EquivalenceStmt>,
common::Indirection<BasedPointerStmt>,
common::Indirection<CUDAAttributesStmt>>
u;
@@ -995,9 +998,11 @@ struct ComponentArraySpec {
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// (F2028) PROTECTED_TARGET |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE | UNIFIED
EMPTY_CLASS(Allocatable);
EMPTY_CLASS(Pointer);
+EMPTY_CLASS(ProtectedTarget);
EMPTY_CLASS(Contiguous);
// CUDA-data-attr [( IMPLICIT )]
// The (IMPLICIT) qualifier marks an attribute that the compiler applied on the
@@ -1013,7 +1018,8 @@ struct CUDADataAttrSpec {
struct ComponentAttrSpec {
UNION_CLASS_BOILERPLATE(ComponentAttrSpec);
std::variant<AccessSpec, Allocatable, CoarraySpec, Contiguous,
- ComponentArraySpec, Pointer, CUDADataAttrSpec, ErrorRecovery>
+ ComponentArraySpec, Pointer, ProtectedTarget, CUDADataAttrSpec,
+ ErrorRecovery>
u;
};
@@ -1407,6 +1413,7 @@ WRAPPER_CLASS(RankClause, ScalarIntConstantExpr);
// INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
// PROTECTED | RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
// VALUE | VOLATILE |
+// (F2028) PROTECTED_TARGET |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE
EMPTY_CLASS(Asynchronous);
EMPTY_CLASS(External);
@@ -1422,8 +1429,8 @@ struct AttrSpec {
UNION_CLASS_BOILERPLATE(AttrSpec);
std::variant<AccessSpec, Allocatable, Asynchronous, CoarraySpec, Contiguous,
ArraySpec, External, IntentSpec, Intrinsic, LanguageBindingSpec, Optional,
- Parameter, Pointer, Protected, RankClause, Save, Target, Value, Volatile,
- CUDADataAttrSpec>
+ Parameter, Pointer, Protected, ProtectedTarget, RankClause, Save, Target,
+ Value, Volatile, CUDADataAttrSpec>
u;
};
@@ -1616,6 +1623,10 @@ WRAPPER_CLASS(PointerStmt, std::list<PointerDecl>);
// R855 protected-stmt -> PROTECTED [::] entity-name-list
WRAPPER_CLASS(ProtectedStmt, std::list<Name>);
+// F2028 R863 protected-target-stmt ->
+// PROTECTED_TARGET [::] variable-name-list
+WRAPPER_CLASS(ProtectedTargetStmt, std::list<Name>);
+
// R857 saved-entity -> object-name | proc-pointer-name | / common-block-name /
// R858 proc-pointer-name -> name
struct SavedEntity {
diff --git a/flang/include/flang/Semantics/attr.h b/flang/include/flang/Semantics/attr.h
index d8b323e88f650..8a76ac6d50bab 100644
--- a/flang/include/flang/Semantics/attr.h
+++ b/flang/include/flang/Semantics/attr.h
@@ -23,8 +23,8 @@ namespace Fortran::semantics {
ENUM_CLASS(Attr, ABSTRACT, ALLOCATABLE, ASYNCHRONOUS, BIND_C, CONTIGUOUS,
DEFERRED, ELEMENTAL, EXTENDS, EXTERNAL, IMPURE, INTENT_IN, INTENT_INOUT,
INTENT_OUT, INTRINSIC, MODULE, NON_OVERRIDABLE, NON_RECURSIVE, NOPASS,
- OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PUBLIC, PURE,
- RECURSIVE, SAVE, SIMPLE, TARGET, VALUE, VOLATILE)
+ OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PROTECTED_TARGET,
+ PUBLIC, PURE, RECURSIVE, SAVE, SIMPLE, TARGET, VALUE, VOLATILE)
// Set of attributes
class Attrs : public common::EnumSet<Attr, Attr_enumSize> {
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 4b05a25fd8f58..923b8d8f77113 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -441,6 +441,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
{Attr::POINTER, DummyDataObject::Attr::Pointer},
{Attr::TARGET, DummyDataObject::Attr::Target},
});
+ result->isProtectedTarget = symbol.attrs().test(Attr::PROTECTED_TARGET);
result->intent = GetIntent(symbol.attrs());
result->ignoreTKR = GetIgnoreTKR(symbol);
if (object) {
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 263ce9249a8b2..e611432a0a5e0 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -469,13 +469,16 @@ TYPE_PARSER(construct<DataComponentDefStmt>(declarationTypeSpec,
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
-// CUDA-data-attr
+// PROTECTED_TARGET | CUDA-data-attr
+constexpr auto protectedTargetAttr{
+ construct<ProtectedTarget>("PROTECTED_TARGET"_tok)};
TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(allocatable) ||
construct<ComponentAttrSpec>("CODIMENSION" >> coarraySpec) ||
construct<ComponentAttrSpec>(contiguous) ||
construct<ComponentAttrSpec>("DIMENSION" >> componentArraySpec) ||
construct<ComponentAttrSpec>(pointer) ||
+ construct<ComponentAttrSpec>(protectedTargetAttr) ||
extension<LanguageFeature::CUDA>(
construct<ComponentAttrSpec>(Parser<CUDADataAttrSpec>{})) ||
construct<ComponentAttrSpec>(recovery(
@@ -742,9 +745,10 @@ TYPE_PARSER(
// CODIMENSION lbracket coarray-spec rbracket | CONTIGUOUS |
// DIMENSION ( array-spec ) | EXTERNAL | INTENT ( intent-spec ) |
// INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
-// PROTECTED | RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
-// VALUE | VOLATILE |
+// PROTECTED | PROTECTED_TARGET | RANK ( scalar-int-constant-expr ) |
+// SAVE | TARGET | VALUE | VOLATILE |
// CUDA-data-attr
+// PROTECTED_TARGET is tried before its prefix PROTECTED.
TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
construct<AttrSpec>(allocatable) ||
construct<AttrSpec>(construct<Asynchronous>("ASYNCHRONOUS"_tok)) ||
@@ -756,7 +760,8 @@ TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
construct<AttrSpec>(construct<Intrinsic>("INTRINSIC"_tok)) ||
construct<AttrSpec>(languageBindingSpec) || construct<AttrSpec>(optional) ||
construct<AttrSpec>(construct<Parameter>("PARAMETER"_tok)) ||
- construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedAttr) ||
+ construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedTargetAttr) ||
+ construct<AttrSpec>(protectedAttr) ||
construct<AttrSpec>("RANK" >>
construct<RankClause>(parenthesized(scalarIntConstantExpr))) ||
construct<AttrSpec>(save) ||
@@ -1050,6 +1055,11 @@ TYPE_PARSER(
TYPE_PARSER(
construct<ProtectedStmt>("PROTECTED" >> maybe("::"_tok) >> listOfNames))
+// F2028 R863 protected-target-stmt ->
+// PROTECTED_TARGET [::] variable-name-list
+TYPE_PARSER(construct<ProtectedTargetStmt>(
+ "PROTECTED_TARGET" >> maybe("::"_tok) >> listOfNames))
+
// R856 save-stmt -> SAVE [[::] saved-entity-list]
TYPE_PARSER(construct<SaveStmt>(
"SAVE" >> defaulted(maybe("::"_tok) >>
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 08283a8be35e3..d20a4becd758d 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -215,9 +215,12 @@ TYPE_CONTEXT_PARSER("specification construct"_en_US,
// access-stmt | allocatable-stmt | asynchronous-stmt | bind-stmt |
// codimension-stmt | contiguous-stmt | dimension-stmt | external-stmt |
// intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
-// pointer-stmt | protected-stmt | save-stmt | target-stmt |
-// volatile-stmt | value-stmt | common-stmt | equivalence-stmt |
+// pointer-stmt | protected-stmt | protected-target-stmt | save-stmt |
+// target-stmt | volatile-stmt | value-stmt | common-stmt |
+// equivalence-stmt |
// (CUDA) CUDA-attributes-stmt
+// protected-target-stmt is tried before protected-stmt, whose keyword is
+// its prefix.
TYPE_PARSER(first(
construct<OtherSpecificationStmt>(indirect(Parser<AccessStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<AllocatableStmt>{})),
@@ -232,6 +235,7 @@ TYPE_PARSER(first(
construct<OtherSpecificationStmt>(indirect(Parser<NamelistStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<OptionalStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<PointerStmt>{})),
+ construct<OtherSpecificationStmt>(indirect(Parser<ProtectedTargetStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<ProtectedStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<SaveStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<TargetStmt>{})),
diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp
index a046c08e710c6..20513f6d376e4 100644
--- a/flang/lib/Parser/unparse.cpp
+++ b/flang/lib/Parser/unparse.cpp
@@ -634,6 +634,7 @@ class UnparseVisitor {
void Post(const Optional &) { Word("OPTIONAL"); }
void Post(const Parameter &) { Word("PARAMETER"); }
void Post(const Protected &) { Word("PROTECTED"); }
+ void Post(const ProtectedTarget &) { Word("PROTECTED_TARGET"); }
void Post(const Save &) { Word("SAVE"); }
void Post(const Target &) { Word("TARGET"); }
void Post(const Value &) { Word("VALUE"); }
@@ -719,6 +720,9 @@ class UnparseVisitor {
void Unparse(const ProtectedStmt &x) { // R855
Word("PROTECTED :: "), Walk(x.v, ", ");
}
+ void Unparse(const ProtectedTargetStmt &x) { // F2028 R863
+ Word("PROTECTED_TARGET :: "), Walk(x.v, ", ");
+ }
void Unparse(const SaveStmt &x) { // R856
Word("SAVE"), Walk(" :: ", x.v, ", ");
}
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index e797b978c4bd3..f78874f96c175 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -510,6 +510,13 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
"Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
return false;
}
+ if (ultimate_->attrs().test(Attr::PROTECTED_TARGET) &&
+ !allocateInfo_.gotSource) { // F'2028 C869
+ context.Say(name_.source,
+ "SOURCE= must appear in ALLOCATE of PROTECTED_TARGET pointer '%s'"_err_en_US,
+ name_.source);
+ return false;
+ }
bool gotSourceExprOrTypeSpec{allocateInfo_.gotMold ||
allocateInfo_.gotTypeSpec || allocateInfo_.gotSource};
if (hasDeferredTypeParameter_ && !gotSourceExprOrTypeSpec) {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index feabf0cd33bf0..091ec8c732622 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -70,6 +70,12 @@ void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
+ // F'2028 C873
+ if (const Symbol *protectedTarget{FindProtectedTargetPointer(*expr)}) {
+ evaluate::SayWithDeclaration(messages, *protectedTarget,
+ "Actual argument designated by PROTECTED_TARGET pointer '%s' requires an explicit interface"_err_en_US,
+ protectedTarget->name());
+ }
if (IsBOZLiteral(*expr)) {
messages.Say("BOZ argument %s requires an explicit interface"_err_en_US,
expr->AsFortran());
@@ -1037,6 +1043,30 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
}
}
+ // F'2028 C872 and C874. A nonpointer dummy argument with INTENT(OUT) or
+ // INTENT(IN OUT) is caught above as a definition of the target, and a
+ // nonallocatable actual argument for an ALLOCATABLE dummy argument without
+ // IGNORE_TKR(P) is already an error above.
+ if (scope && !intrinsic) {
+ if (const Symbol *protectedTarget{FindProtectedTargetPointer(actual)}) {
+ bool isNonallocatableActualError{dummyIsAllocatable &&
+ !actualIsAllocatable &&
+ !dummy.ignoreTKR.test(common::IgnoreTKR::Pointer)};
+ if (dummyIsPointer) {
+ if (!dummy.isProtectedTarget) {
+ evaluate::SayWithDeclaration(messages, *protectedTarget,
+ "POINTER %s must have the PROTECTED_TARGET attribute because its actual argument is designated by PROTECTED_TARGET pointer '%s'"_err_en_US,
+ dummyName, protectedTarget->name());
+ }
+ } else if (dummy.intent == common::Intent::Default &&
+ !isNonallocatableActualError) {
+ evaluate::SayWithDeclaration(messages, *protectedTarget,
+ "Nonpointer %s must have INTENT(IN) because its actual argument is designated by PROTECTED_TARGET pointer '%s'"_err_en_US,
+ dummyName, protectedTarget->name());
+ }
+ }
+ }
+
// 15.5.2.7 -- dummy is POINTER
if (dummyIsPointer) {
if (actualIsPointer || dummy.intent == common::Intent::In) {
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 2abefd381850a..e5ed8727638e2 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -347,6 +347,16 @@ void CheckHelper::Check(const Symbol &symbol) {
"A PROTECTED entity may not be in a common block"_err_en_US);
}
}
+ if (symbol.attrs().test(Attr::PROTECTED_TARGET)) {
+ if (!IsObjectPointer(&symbol)) { // F'2028 8.5.16p1, C781, C8109
+ messages_.Say(
+ "A PROTECTED_TARGET entity must be a data pointer"_err_en_US);
+ }
+ if (FindCommonBlockContaining(symbol)) { // F'2028 C867
+ messages_.Say(
+ "A PROTECTED_TARGET entity may not be in a common block"_err_en_US);
+ }
+ }
if (IsPointer(symbol)) {
CheckPointer(symbol);
}
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 6193b297b62fb..a9be9842393a0 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -6184,8 +6184,16 @@ void OmpStructureChecker::CheckDefinableObjects(
if (!IsVariableListItem(*symbol)) {
continue;
}
- if (auto msg{WhyNotDefinable(source, context_.FindScope(source),
- DefinabilityFlags{}, *symbol)}) {
+ DefinabilityFlags flags;
+ // A LASTPRIVATE pointer is updated as if by pointer assignment, so the
+ // target of a PROTECTED_TARGET pointer is not defined; other pointers
+ // keep the existing checks.
+ if (clause == llvm::omp::Clause::OMPC_lastprivate && IsPointer(*symbol) &&
+ symbol->attrs().test(Attr::PROTECTED_TARGET)) {
+ flags.set(DefinabilityFlag::PointerDefinition);
+ }
+ if (auto msg{WhyNotDefinable(
+ source, context_.FindScope(source), flags, *symbol)}) {
context_
.Say(source,
"Variable '%s' on the %s clause is not definable"_err_en_US,
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index d6a654683001f..374462c040fdb 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -94,6 +94,117 @@ static bool DefinesComponentPointerTarget(
}
}
+// F'2028 8.5.16p2 (J3/26-007r1): the target of a data pointer with the
+// PROTECTED_TARGET attribute is not definable via that pointer.
+// These functions find the pointer whose target contains the object that a
+// designator defines. When a pointer itself is being defined (a pointer
+// association context), its association is part of the object designated by
+// the rest of the designator. With followAssociations, an associate name
+// stands for its selector (J3/26-007r1 20.6.7(11)).
+static const Symbol *FindProtectedTargetPointer(
+ const evaluate::Expr<evaluate::SomeType> &, bool isPointerDefinition,
+ bool followAssociations);
+
+static const Symbol *IfProtectedTarget(const Symbol &pointer) {
+ if (pointer.GetUltimate().attrs().test(Attr::PROTECTED_TARGET)) {
+ return &pointer;
+ } else {
+ return nullptr;
+ }
+}
+
+static const Symbol *FindProtectedTargetPointer(
+ const Symbol &symbol, bool isPointerDefinition, bool followAssociations) {
+ const Symbol &ultimate{symbol.GetUltimate()};
+ if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()};
+ association && association->expr() && followAssociations) {
+ return FindProtectedTargetPointer(
+ *association->expr(), isPointerDefinition, followAssociations);
+ } else if (IsPointer(ultimate)) {
+ return isPointerDefinition ? nullptr : IfProtectedTarget(symbol);
+ } else {
+ return nullptr;
+ }
+}
+
+static const Symbol *FindProtectedTargetPointer(const evaluate::DataRef &,
+ bool isPointerDefinition, bool followAssociations);
+
+static const Symbol *FindProtectedTargetPointer(
+ const evaluate::Component &component, bool isPointerDefinition,
+ bool followAssociations) {
+ const Symbol &last{component.GetLastSymbol()};
+ if (IsPointer(last) && !isPointerDefinition) {
+ return IfProtectedTarget(last);
+ }
+ return FindProtectedTargetPointer(component.base(),
+ /*isPointerDefinition=*/false, followAssociations);
+}
+
+static const Symbol *FindProtectedTargetPointer(
+ const evaluate::DataRef &dataRef, bool isPointerDefinition,
+ bool followAssociations) {
+ return common::visit(
+ common::visitors{
+ [&](const SymbolRef &symbol) {
+ return FindProtectedTargetPointer(
+ *symbol, isPointerDefinition, followAssociations);
+ },
+ [&](const evaluate::Component &component) {
+ return FindProtectedTargetPointer(
+ component, isPointerDefinition, followAssociations);
+ },
+ [&](const evaluate::ArrayRef &arrayRef) {
+ // Elements and sections are subobjects of the base's target.
+ const evaluate::NamedEntity &base{arrayRef.base()};
+ if (const auto *component{base.UnwrapComponent()}) {
+ return FindProtectedTargetPointer(*component,
+ /*isPointerDefinition=*/false, followAssociations);
+ } else {
+ return FindProtectedTargetPointer(base.GetLastSymbol(),
+ /*isPointerDefinition=*/false, followAssociations);
+ }
+ },
+ [](const evaluate::CoarrayRef &) -> const Symbol * {
+ return nullptr; // a coarray is not a pointer
+ },
+ },
+ dataRef.u);
+}
+
+static const Symbol *FindProtectedTargetPointer(
+ const evaluate::Expr<evaluate::SomeType> &expr, bool isPointerDefinition,
+ bool followAssociations) {
+ if (auto dataRef{evaluate::ExtractDataRef(
+ expr, /*intoSubstring=*/true, /*intoComplexPart=*/true)}) {
+ return FindProtectedTargetPointer(
+ *dataRef, isPointerDefinition, followAssociations);
+ } else if (const auto *funcRef{evaluate::UnwrapProcedureRef(expr)};
+ funcRef && !isPointerDefinition) {
+ if (const Symbol *proc{funcRef->proc().GetSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*proc)};
+ result && IsPointer(*result)) {
+ return IfProtectedTarget(*result);
+ }
+ }
+ }
+ return nullptr;
+}
+
+const Symbol *FindProtectedTargetPointer(
+ const evaluate::Expr<evaluate::SomeType> &expr) {
+ return FindProtectedTargetPointer(expr, /*isPointerDefinition=*/false,
+ /*followAssociations=*/false);
+}
+
+// F'2028 C866, 8.5.16p2
+static parser::Message WhyProtectedTargetIsNotDefinable(
+ parser::CharBlock at, const Symbol &pointer) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable via that pointer"_en_US,
+ pointer);
+}
+
// Check the leftmost (or only) symbol from a data-ref or expression.
static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags, const Symbol &original,
@@ -258,6 +369,11 @@ static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
DefinesComponentPointerTarget(dataRef, flags))};
if (!whyNotBase || !whyNotBase->IsFatal()) {
+ if (const Symbol *pointer{FindProtectedTargetPointer(dataRef,
+ flags.test(DefinabilityFlag::PointerDefinition),
+ /*followAssociations=*/true)}) {
+ return WhyProtectedTargetIsNotDefinable(at, *pointer);
+ }
if (auto whyNotLast{
WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol())}) {
if (whyNotLast->IsFatal() || !whyNotBase) {
@@ -273,6 +389,11 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
/*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
if (!whyNotBase || !whyNotBase->IsFatal()) {
+ if (const Symbol *pointer{FindProtectedTargetPointer(original,
+ flags.test(DefinabilityFlag::PointerDefinition),
+ /*followAssociations=*/true)}) {
+ return WhyProtectedTargetIsNotDefinable(at, *pointer);
+ }
if (auto whyNotLast{WhyNotDefinableLast(at, scope, flags, original)}) {
if (whyNotLast->IsFatal() || !whyNotBase) {
return whyNotLast;
@@ -422,6 +543,10 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
}
return parser::Message{
at, "'%s' is not a definable pointer"_err_en_US, expr.AsFortran()};
+ } else if (const Symbol *result{
+ FindProtectedTargetPointer(expr, /*isPointerDefinition=*/false,
+ /*followAssociations=*/true)}) {
+ return WhyProtectedTargetIsNotDefinable(at, *result);
} else if (!evaluate::IsVariable(expr)) {
return parser::Message{
at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h
index 816dad3c17fab..f076b1ddddadc 100644
--- a/flang/lib/Semantics/definable.h
+++ b/flang/lib/Semantics/definable.h
@@ -54,5 +54,13 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock, const Scope &,
// describing why.
const char *WhyBaseObjectIsSuspicious(const Symbol &, const Scope &);
+// F'2028 C870-C874 (J3/26-007r1): when an expression is a data pointer with
+// the PROTECTED_TARGET attribute, or a subobject of that pointer's target,
+// returns that pointer; for a reference to a function whose result is such
+// a pointer, returns the result. A pointer component that follows it in the
+// designator designates its own target (F'2023 9.4.2p5).
+const Symbol *FindProtectedTargetPointer(
+ const evaluate::Expr<evaluate::SomeType> &);
+
} // namespace Fortran::semantics
#endif // FORTRAN_SEMANTICS_DEFINABLE_H_
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..e433e9bfc9695 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -50,10 +50,13 @@ class PointerAssignmentChecker {
set_lhsType(TypeAndShape::Characterize(lhs, foldingContext_));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
+ set_isProtectedTarget(lhs.attrs().test(Attr::PROTECTED_TARGET));
}
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_isContiguous(bool);
PointerAssignmentChecker &set_isVolatile(bool);
+ PointerAssignmentChecker &set_isProtectedTarget(bool);
+ PointerAssignmentChecker &set_isInitialization(bool);
PointerAssignmentChecker &set_isBoundsRemapping(bool);
PointerAssignmentChecker &set_isAssumedRank(bool);
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
@@ -92,6 +95,8 @@ class PointerAssignmentChecker {
bool characterizedProcedure_{false};
bool isContiguous_{false};
bool isVolatile_{false};
+ bool isProtectedTarget_{false};
+ bool isInitialization_{false};
bool isBoundsRemapping_{false};
bool isAssumedRank_{false};
bool isRHSPointerActualArgument_{false};
@@ -117,6 +122,18 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isProtectedTarget(
+ bool isProtectedTarget) {
+ isProtectedTarget_ = isProtectedTarget;
+ return *this;
+}
+
+PointerAssignmentChecker &PointerAssignmentChecker::set_isInitialization(
+ bool isInitialization) {
+ isInitialization_ = isInitialization;
+ return *this;
+}
+
PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
bool isBoundsRemapping) {
isBoundsRemapping_ = isBoundsRemapping;
@@ -207,6 +224,17 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
if (lhs_ && IsProcedure(*lhs_)) {
return true;
}
+ // F'2028 C870 (pointer assignment) and C871 (structure constructor);
+ // C872 for dummy arguments is checked with the call.
+ if (lhs_ && !isProtectedTarget_) {
+ if (const Symbol *protectedTarget{FindProtectedTargetPointer(rhs)}) {
+ evaluate::AttachDeclaration(
+ Say("Pointer '%s' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer '%s'"_err_en_US,
+ lhs_->name(), protectedTarget->name()),
+ *protectedTarget);
+ return false;
+ }
+ }
if (const auto *pureProc{FindPureProcedureContaining(scope_)}) {
if (pointerComponentLHS_) { // F'2023 C15104(4) is a hard error
if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) {
@@ -243,13 +271,22 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
"Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
}
}
- // Warn about undefinable data targets
- if (auto because{
- WhyNotDefinable(foldingContext_.messages().at(), scope_, {}, rhs)}) {
- if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
- "Pointer target is not a definable variable"_warn_en_US)}) {
- msg->Attach(std::move(because->set_severity(parser::Severity::Because)));
- return false;
+ // Warn about undefinable data targets. A PROTECTED_TARGET pointer cannot
+ // define its target, so F'2028 8.5.16 NOTE 1 associates one with a
+ // USE-associated PROTECTED TARGET (p => x) although C864 still lists that
+ // case; this follows the note except for an initial-data-target, which the
+ // note does not show. A target designated by a PROTECTED_TARGET pointer
+ // is subject to C870-C872 instead.
+ if ((!isProtectedTarget_ || isInitialization_) &&
+ !FindProtectedTargetPointer(rhs)) {
+ if (auto because{WhyNotDefinable(
+ foldingContext_.messages().at(), scope_, {}, rhs)}) {
+ if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
+ "Pointer target is not a definable variable"_warn_en_US)}) {
+ msg->Attach(
+ std::move(because->set_severity(parser::Severity::Because)));
+ return false;
+ }
}
}
return true;
@@ -585,7 +622,7 @@ bool CheckPointerAssignment(SemanticsContext &context,
bool CheckPointerAssignment(SemanticsContext &context, const SomeExpr &lhs,
const SomeExpr &rhs, const Scope &scope, bool isBoundsRemapping,
- bool isAssumedRank) {
+ bool isAssumedRank, bool isInitialization) {
const Symbol *pointer{GetLastSymbol(lhs)};
if (!pointer) {
return false; // error was reported
@@ -599,6 +636,7 @@ bool CheckPointerAssignment(SemanticsContext &context, const SomeExpr &lhs,
}
checker.set_isBoundsRemapping(isBoundsRemapping);
checker.set_isAssumedRank(isAssumedRank);
+ checker.set_isInitialization(isInitialization);
bool lhsOk{checker.CheckLeftHandSide(lhs)};
bool rhsOk{checker.Check(rhs)};
return lhsOk && rhsOk; // don't short-circuit
@@ -619,6 +657,7 @@ bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
.set_lhsType(common::Clone(lhs.type))
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
.set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
+ .set_isProtectedTarget(lhs.isProtectedTarget)
.set_isAssumedRank(isAssumedRank)
.set_isRHSPointerActualArgument(isPointerActualArgument)
.set_ignoreTKR(lhs.ignoreTKR)
@@ -631,7 +670,7 @@ bool CheckInitialDataPointerTarget(SemanticsContext &context,
&context.foldingContext().messages(), &context.foldingContext()) &&
CheckPointerAssignment(context, pointer, init, scope,
/*isBoundsRemapping=*/false,
- /*isAssumedRank=*/false);
+ /*isAssumedRank=*/false, /*isInitialization=*/true);
}
} // namespace Fortran::semantics
diff --git a/flang/lib/Semantics/pointer-assignment.h b/flang/lib/Semantics/pointer-assignment.h
index ad7c6554d5a13..58ab5d1f13e55 100644
--- a/flang/lib/Semantics/pointer-assignment.h
+++ b/flang/lib/Semantics/pointer-assignment.h
@@ -27,7 +27,7 @@ bool CheckPointerAssignment(
SemanticsContext &, const evaluate::Assignment &, const Scope &);
bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs,
const SomeExpr &rhs, const Scope &, bool isBoundsRemapping,
- bool isAssumedRank);
+ bool isAssumedRank, bool isInitialization = false);
bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source,
const std::string &description,
const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs,
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 3571a1de521f7..dca0299b546a7 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -299,6 +299,7 @@ class AttrsVisitor : public virtual BaseVisitor {
HANDLE_ATTR_CLASS(Parameter, PARAMETER)
HANDLE_ATTR_CLASS(Pointer, POINTER)
HANDLE_ATTR_CLASS(Protected, PROTECTED)
+ HANDLE_ATTR_CLASS(ProtectedTarget, PROTECTED_TARGET)
HANDLE_ATTR_CLASS(Save, SAVE)
HANDLE_ATTR_CLASS(Target, TARGET)
HANDLE_ATTR_CLASS(Value, VALUE)
@@ -1090,6 +1091,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool Pre(const parser::IntrinsicStmt &);
bool Pre(const parser::OptionalStmt &);
bool Pre(const parser::ProtectedStmt &);
+ bool Pre(const parser::ProtectedTargetStmt &);
bool Pre(const parser::ValueStmt &);
bool Pre(const parser::VolatileStmt &);
bool Pre(const parser::AllocatableStmt &) {
@@ -6763,6 +6765,9 @@ bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) {
bool DeclarationVisitor::Pre(const parser::ProtectedStmt &x) {
return HandleAttributeStmt(Attr::PROTECTED, x.v);
}
+bool DeclarationVisitor::Pre(const parser::ProtectedTargetStmt &x) {
+ return HandleAttributeStmt(Attr::PROTECTED_TARGET, x.v);
+}
bool DeclarationVisitor::Pre(const parser::ValueStmt &x) {
return CheckNotInBlock("VALUE") && // C1107
HandleAttributeStmt(Attr::VALUE, x.v);
diff --git a/flang/test/Parser/protected-target.f90 b/flang/test/Parser/protected-target.f90
new file mode 100644
index 0000000000000..f25ffa78662be
--- /dev/null
+++ b/flang/test/Parser/protected-target.f90
@@ -0,0 +1,47 @@
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fdebug-dump-parse-tree-no-sema %s 2>&1 | FileCheck %s --check-prefix=TREE
+! Test parsing and unparsing of the PROTECTED_TARGET attribute, component
+! attribute, and statement (F2028 draft J3/26-007r1).
+
+module m
+ type t
+ real, pointer, protected_target :: c1
+ real, protected_target, pointer :: c2(:)
+ end type
+ real, pointer, protected_target :: p1
+ real, protected_target :: p2
+ real, pointer :: p3, p4
+ pointer :: p2
+ protected_target :: p3
+ protected_target p4
+ real, pointer :: protected_target
+ protected protected_target
+ contains
+ function f() result(r)
+ real, pointer, protected_target :: r
+ r => null()
+ end function
+end module
+
+!CHECK: MODULE m
+!CHECK: TYPE :: t
+!CHECK: REAL, POINTER, PROTECTED_TARGET :: c1
+!CHECK: REAL, PROTECTED_TARGET, POINTER :: c2(:)
+!CHECK: END TYPE
+!CHECK: REAL, POINTER, PROTECTED_TARGET :: p1
+!CHECK: REAL, PROTECTED_TARGET :: p2
+!CHECK: REAL, POINTER :: p3, p4
+!CHECK: POINTER :: p2
+!CHECK: PROTECTED_TARGET :: p3
+!CHECK: PROTECTED_TARGET :: p4
+!CHECK: REAL, POINTER :: protected_target
+!CHECK: PROTECTED :: protected_target
+!CHECK: CONTAINS
+!CHECK: FUNCTION f() RESULT(r)
+!CHECK: REAL, POINTER, PROTECTED_TARGET :: r
+
+!TREE: ComponentAttrSpec -> ProtectedTarget
+!TREE: AttrSpec -> ProtectedTarget
+!TREE: OtherSpecificationStmt -> ProtectedTargetStmt -> Name = 'p3'
+!TREE: OtherSpecificationStmt -> ProtectedTargetStmt -> Name = 'p4'
+!TREE: OtherSpecificationStmt -> ProtectedStmt -> Name = 'protected_target'
diff --git a/flang/test/Semantics/OpenMP/lastprivate-protected-target.f90 b/flang/test/Semantics/OpenMP/lastprivate-protected-target.f90
new file mode 100644
index 0000000000000..168be3c213895
--- /dev/null
+++ b/flang/test/Semantics/OpenMP/lastprivate-protected-target.f90
@@ -0,0 +1,15 @@
+! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp
+! A LASTPRIVATE pointer is updated as if by pointer assignment, so a
+! PROTECTED_TARGET pointer (F2028 draft J3/26-007r1) may appear in the clause.
+
+subroutine s(x)
+ real, target :: x
+ real, pointer, protected_target :: p
+ integer :: i
+ !$omp parallel do lastprivate(p)
+ do i = 1, 2
+ p => x
+ end do
+ !$omp end parallel do
+ print *, associated(p)
+end
diff --git a/flang/test/Semantics/modfile-protected-target.f90 b/flang/test/Semantics/modfile-protected-target.f90
new file mode 100644
index 0000000000000..89b9c343f9e1e
--- /dev/null
+++ b/flang/test/Semantics/modfile-protected-target.f90
@@ -0,0 +1,30 @@
+! RUN: %python %S/test_modfile.py %s %flang_fc1
+! PROTECTED_TARGET attribute (F2028 draft J3/26-007r1) in module files
+module m
+ real, pointer, protected_target :: p1
+ real, pointer :: p2(:)
+ protected_target :: p2
+ type t
+ real, pointer, protected_target :: c
+ end type
+ contains
+ function f(a) result(r)
+ real, pointer, protected_target, intent(in) :: a
+ real, pointer, protected_target :: r
+ r => a
+ end
+end
+
+!Expect: m.mod
+!module m
+!real(4),pointer,protected_target::p1
+!real(4),pointer,protected_target::p2(:)
+!type::t
+!real(4),pointer,protected_target::c
+!end type
+!contains
+!function f(a) result(r)
+!real(4),intent(in),pointer,protected_target::a
+!real(4),pointer,protected_target::r
+!end
+!end
diff --git a/flang/test/Semantics/protected-target01.f90 b/flang/test/Semantics/protected-target01.f90
new file mode 100644
index 0000000000000..a13965b24e4f9
--- /dev/null
+++ b/flang/test/Semantics/protected-target01.f90
@@ -0,0 +1,143 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! PROTECTED_TARGET attribute (F2028 draft J3/26-007r1): declarations (C781,
+! C867, C8109) and definitions of the target (C866, C868, C869, 8.5.16p2)
+module m
+ real, target :: x0
+ real, pointer, protected_target :: p0
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real, protected_target :: notPointer
+ type t
+ real, pointer, protected_target :: c1
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real, protected_target :: c2
+ real :: v
+ real, pointer :: q
+ real, allocatable :: a(:)
+ end type
+ contains
+ function getp() result(r)
+ real, pointer, protected_target :: r
+ r => x0
+ end
+ subroutine statements
+ real, pointer :: sp
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real :: notPointer2
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ procedure(), pointer :: procPtr
+ protected_target :: sp, notPointer2
+ protected_target procPtr
+ end
+ subroutine commonBlock
+ !ERROR: A PROTECTED_TARGET entity may not be in a common block
+ real, pointer, protected_target :: pc
+ common /blk/ pc
+ end
+ subroutine definitions(p, x, n)
+ real, pointer, protected_target :: p(:)
+ real, target :: x(:)
+ integer, pointer, protected_target :: n
+ type(t), pointer, protected_target :: pt
+ type(t), target :: tt
+ p => x
+ nullify(p)
+ p => x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p = 1.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p(1:1) = 1.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ if (.false.) p(1) = 2.
+ !ERROR: Input variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ read *, p
+ !ERROR: 'n' may not be used as a DO variable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'n' is not definable via that pointer
+ do n = 1, 2
+ end do
+ x = 1. ! the target is still definable by other means
+ pt => tt
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable via that pointer
+ pt%v = 1.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable via that pointer
+ pt%a = [1.]
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable via that pointer
+ pt%q => x(1)
+ !ERROR: 'q' may not appear in NULLIFY
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable via that pointer
+ nullify(pt%q)
+ pt%q = 1. ! the target of a pointer component is not the target of pt
+ tt%c1 => x(1)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'c1' is not definable via that pointer
+ tt%c1 = 1.
+ associate (a => p, b => p(1), c => pt%q)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ a = 1.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ b = 1.
+ c = 1.
+ end associate
+ print *, p, n, pt%v, tt%c1, getp()
+ end
+ subroutine selectors(u, rr)
+ class(*), pointer, protected_target :: u
+ real, pointer, protected_target :: rr(..)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'r' is not definable via that pointer
+ getp() = 1.
+ associate (d => getp())
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'r' is not definable via that pointer
+ d = 2.
+ end associate
+ select type (v => u)
+ type is (integer)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'u' is not definable via that pointer
+ v = 1
+ end select
+ select rank (a => rr)
+ rank (1)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'rr' is not definable via that pointer
+ a(1) = 1.
+ end select
+ end
+ subroutine allocations
+ real, pointer, protected_target :: p, ps(:)
+ type(t), pointer, protected_target :: pt
+ type(t) :: tt
+ !ERROR: SOURCE= must appear in ALLOCATE of PROTECTED_TARGET pointer 'p'
+ allocate(p)
+ !ERROR: SOURCE= must appear in ALLOCATE of PROTECTED_TARGET pointer 'ps'
+ allocate(ps(2), mold=[1., 2.])
+ !ERROR: SOURCE= must appear in ALLOCATE of PROTECTED_TARGET pointer 'c1'
+ allocate(tt%c1)
+ allocate(p, source=1.)
+ allocate(ps, source=[1., 2.])
+ allocate(tt%c1, source=2.)
+ allocate(pt, source=tt)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable via that pointer
+ allocate(pt%a(2))
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ deallocate(p)
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'c1' is not definable via that pointer
+ deallocate(tt%c1)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable via that pointer
+ deallocate(pt%a)
+ nullify(p, ps, pt)
+ end
+end
diff --git a/flang/test/Semantics/protected-target02.f90 b/flang/test/Semantics/protected-target02.f90
new file mode 100644
index 0000000000000..fa414c5c67445
--- /dev/null
+++ b/flang/test/Semantics/protected-target02.f90
@@ -0,0 +1,182 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! PROTECTED_TARGET attribute (F2028 draft J3/26-007r1): pointer association,
+! structure constructors, and actual arguments (C870-C874)
+module m
+ type t
+ real :: v
+ real, pointer :: q
+ real, pointer, protected_target :: pq
+ end type
+ type ta
+ real, allocatable :: a(:)
+ end type
+ interface gen
+ subroutine genReal(a)
+ real, pointer :: a
+ end
+ subroutine genInteger(n)
+ integer, pointer :: n
+ end
+ end interface
+ interface
+ subroutine plainPointer(a)
+ real, pointer :: a
+ end
+ subroutine ptPointer(a)
+ real, pointer, protected_target :: a
+ end
+ subroutine inPointer(a)
+ real, pointer, intent(in) :: a(:)
+ end
+ subroutine ptInPointer(a)
+ real, pointer, protected_target, intent(in) :: a(:)
+ end
+ subroutine ptOutPointer(a)
+ real, pointer, protected_target, intent(out) :: a
+ end
+ subroutine noIntent(a)
+ real :: a
+ end
+ subroutine inIntent(a)
+ real, intent(in) :: a
+ end
+ subroutine outIntent(a)
+ real, intent(out) :: a
+ end
+ subroutine valueArg(a)
+ real, value :: a
+ end
+ subroutine allocNoIntent(a)
+ real, allocatable :: a(:)
+ end
+ subroutine allocIn(a)
+ real, allocatable, intent(in) :: a(:)
+ end
+ subroutine allocTkr(a)
+ !dir$ ignore_tkr(p) a
+ real, allocatable :: a(:)
+ end
+ function ptResult()
+ real, pointer, protected_target :: ptResult
+ end
+ function plainResult()
+ real, pointer :: plainResult
+ end
+ end interface
+ interface
+ module subroutine separate(a)
+ real, pointer, protected_target :: a
+ end
+ end interface
+ contains
+ subroutine association(x, xs)
+ real, target :: x, xs(:)
+ real, pointer :: w, ws(:)
+ real, pointer, protected_target :: p, ps(:), p2
+ type(t) :: tt
+ type(t), pointer, protected_target :: pt
+ p => x
+ ps => xs
+ p2 => p
+ p2 => w
+ p2 => ptResult()
+ p2 => plainResult()
+ w => pt%q
+ !ERROR: Pointer 'w' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'p'
+ w => p
+ !ERROR: Pointer 'ws' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'ps'
+ ws => ps(1:1)
+ !ERROR: Pointer 'w' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'pt'
+ w => pt%v
+ !ERROR: Pointer 'w' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'pq'
+ w => tt%pq
+ !ERROR: Pointer 'w' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'ptresult'
+ w => ptResult()
+ w => plainResult()
+ tt = t(1., w, p)
+ tt = t(1., pt%q, pt%pq)
+ !ERROR: Pointer 'q' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'p'
+ tt = t(1., p, p)
+ !ERROR: Pointer 'q' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'ps'
+ tt = t(v=1., q=ps(1), pq=ps(2))
+ print *, associated(p), associated(w, p), size(ps)
+ end
+ subroutine arguments(x)
+ real, target :: x
+ real, pointer :: w
+ real, pointer, protected_target :: p, ps(:)
+ type(t), pointer, protected_target :: pt
+ type(ta), pointer, protected_target :: pa
+ integer, pointer :: n
+ external :: ext
+ p => x
+ call plainPointer(w)
+ call ptPointer(w)
+ call ptPointer(p)
+ call ptOutPointer(p)
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute because its actual argument is designated by PROTECTED_TARGET pointer 'p'
+ call plainPointer(p)
+ call gen(w)
+ call gen(n)
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute because its actual argument is designated by PROTECTED_TARGET pointer 'p'
+ call gen(p)
+ call ptInPointer(ps)
+ call ptInPointer(ps(1:1))
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute because its actual argument is designated by PROTECTED_TARGET pointer 'ps'
+ call inPointer(ps(1:1))
+ call inIntent(p)
+ call inIntent(ps(1))
+ call inIntent(ptResult())
+ call noIntent(pt%q)
+ !ERROR: Nonpointer dummy argument 'a=' must have INTENT(IN) because its actual argument is designated by PROTECTED_TARGET pointer 'p'
+ call noIntent(p)
+ !ERROR: Nonpointer dummy argument 'a=' must have INTENT(IN) because its actual argument is designated by PROTECTED_TARGET pointer 'pt'
+ call noIntent(pt%v)
+ !ERROR: Nonpointer dummy argument 'a=' must have INTENT(IN) because its actual argument is designated by PROTECTED_TARGET pointer 'ptresult'
+ call noIntent(ptResult())
+ !ERROR: Nonpointer dummy argument 'a=' must have INTENT(IN) because its actual argument is designated by PROTECTED_TARGET pointer 'p'
+ call valueArg(p)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'a=' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ call outIntent(p)
+ call allocIn(pa%a)
+ !ERROR: Nonpointer dummy argument 'a=' must have INTENT(IN) because its actual argument is designated by PROTECTED_TARGET pointer 'pa'
+ call allocNoIntent(pa%a)
+ !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument
+ call allocNoIntent(ps)
+ !ERROR: Nonpointer dummy argument 'a=' must have INTENT(IN) because its actual argument is designated by PROTECTED_TARGET pointer 'ps'
+ call allocTkr(ps)
+ call ext(pt%q)
+ call ext(p + 1.)
+ !ERROR: Actual argument designated by PROTECTED_TARGET pointer 'p' requires an explicit interface
+ call ext(p)
+ !ERROR: Actual argument designated by PROTECTED_TARGET pointer 'ps' requires an explicit interface
+ call ext(ps(1))
+ end
+ ! PROTECTED_TARGET is not a characteristic (F2028 draft 15.3.2.2, 15.3.3),
+ ! so it does not affect interface compatibility; C872 applies to the
+ ! interface through which a procedure is referenced.
+ subroutine characteristics(x)
+ real, target :: x
+ real, pointer, protected_target :: p
+ procedure(ptPointer), pointer :: pp1
+ procedure(plainPointer), pointer :: pp2
+ procedure(plainResult), pointer :: fp1
+ procedure(ptResult), pointer :: fp2
+ p => x
+ pp1 => plainPointer
+ pp2 => ptPointer
+ fp1 => ptResult
+ fp2 => plainResult
+ call pp1(p)
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute because its actual argument is designated by PROTECTED_TARGET pointer 'p'
+ call pp2(p)
+ end
+end
+
+submodule (m) sm
+ contains
+ module subroutine separate(a)
+ real, pointer :: a
+ end
+end
diff --git a/flang/test/Semantics/protected-target03.f90 b/flang/test/Semantics/protected-target03.f90
new file mode 100644
index 0000000000000..10ad672f1c6ce
--- /dev/null
+++ b/flang/test/Semantics/protected-target03.f90
@@ -0,0 +1,80 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Wpointer-to-undefinable
+! PROTECTED_TARGET attribute (F2028 draft J3/26-007r1): C864 forbids a
+! USE-associated nonpointer PROTECTED object as a data-target, while 8.5.16
+! NOTE 1 associates a PROTECTED_TARGET pointer with exactly such an object.
+! Flang follows NOTE 1: the target cannot be defined via a PROTECTED_TARGET
+! pointer, so that pointer assignment has no diagnostic. An
+! initial-data-target, which NOTE 1 does not show, keeps the existing optional
+! warning, as does an ordinary pointer.
+module m
+ real, protected, target :: x = 1.
+ real, pointer, protected_target :: p
+ contains
+ subroutine inside
+ real, pointer :: w
+ w => x
+ p => x
+ end
+end
+
+module initialization
+ use m
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ real, pointer, protected_target :: ip => x
+ type t
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ real, pointer, protected_target :: c => x
+ end type
+end
+
+subroutine outside
+ use m
+ real, pointer :: w
+ real, pointer, protected_target :: q
+ p => x
+ q => x
+ q => p
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ w => x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p = 999.
+end
+
+subroutine intentIn(y)
+ real, intent(in), target :: y
+ real, pointer :: w
+ real, pointer, protected_target :: q
+ q => y
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'y' is an INTENT(IN) dummy argument
+ w => y
+ print *, associated(q), associated(q, y)
+end
+
+subroutine intrinsicPointerArgs(c)
+ use iso_c_binding, only: c_ptr, c_f_pointer
+ type(c_ptr), intent(in) :: c
+ real, pointer, protected_target :: q
+ call c_f_pointer(c, q)
+ print *, associated(q)
+end
+
+! C870-C874 name the pointer and its subobjects, not an associate name, so
+! an associate name used as a data-target or actual argument is not
+! diagnosed by them; the data-target here gets only the optional warning.
+! Defining the associate name is still an error (protected-target01.f90).
+subroutine associateName(p)
+ real, pointer, protected_target :: p
+ real, pointer :: w
+ external :: ext
+ associate (a => p)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ w => a
+ call ext(a)
+ end associate
+end
diff --git a/flang/test/Semantics/protected-target04.f90 b/flang/test/Semantics/protected-target04.f90
new file mode 100644
index 0000000000000..d344a5e168359
--- /dev/null
+++ b/flang/test/Semantics/protected-target04.f90
@@ -0,0 +1,56 @@
+! RUN: rm -rf %t && split-file %s %t
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/m.f90
+! RUN: %python %S/test_errors.py %t/use.f90 %flang_fc1 -J%t
+! PROTECTED_TARGET attribute (F2028 draft J3/26-007r1): the constraints apply
+! to entities and procedure characteristics read back from a module file.
+
+!--- m.f90
+module m
+ real, target :: x = 1.
+ real, pointer, protected_target :: p
+ type t
+ real, pointer :: q
+ real, pointer, protected_target :: pq
+ end type
+ contains
+ subroutine ptDummy(a)
+ real, pointer, protected_target, intent(in) :: a
+ end
+ function ptResult()
+ real, pointer, protected_target :: ptResult
+ ptResult => x
+ end
+end
+
+!--- use.f90
+subroutine user
+ use m
+ interface
+ subroutine plainDummy(a)
+ real, pointer, intent(in) :: a
+ end
+ end interface
+ real, pointer :: w
+ real, pointer, protected_target :: q
+ type(t) :: tt
+ procedure(ptDummy), pointer :: pp
+ p => x
+ q => p
+ q => ptResult()
+ tt = t(w, p)
+ call ptDummy(p)
+ pp => ptDummy
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p = 2.
+ !ERROR: Pointer 'w' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'p'
+ w => p
+ !ERROR: Pointer 'w' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'ptresult'
+ w => ptResult()
+ !ERROR: Pointer 'q' must have the PROTECTED_TARGET attribute because its target is designated by PROTECTED_TARGET pointer 'p'
+ tt = t(p, p)
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute because its actual argument is designated by PROTECTED_TARGET pointer 'p'
+ call plainDummy(p)
+ ! PROTECTED_TARGET is not a characteristic (F2028 draft 15.3.2.2).
+ pp => plainDummy
+end
More information about the flang-commits
mailing list