[flang-commits] [flang] [flang] Add the Fortran 2028 PROTECTED_TARGET attribute (PR #230865)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Sat Oct 10 22:07:35 PDT 2026
https://github.com/Saieiei updated https://github.com/llvm/llvm-project/pull/230865
>From bb129c14d5da96fdd7abe37707cbcc9d7d836dcf Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Sun, 11 Oct 2026 00:07:25 -0500
Subject: [PATCH] [flang] Add the Fortran 2028 PROTECTED_TARGET attribute
The Fortran 2028 working draft (J3/26-007r1 8.5.16, 8.6.14) adds the
PROTECTED_TARGET attribute: the target of such a data pointer cannot be
defined or become undefined through it. Flang rejected it in the parser.
Parse the attribute and the statement, keep the attribute in module files,
and report C781, C866-C874 and C8109 as errors in the existing checks. A
pointer component of the target, such as `p%next`, is a subobject of the
target where it is not dereferenced (9.4.2 NOTE 1), so `w => p%next` is an
error while `p%next = 1` is not. An associate name stands for its selector
only in definition contexts, except a RANK DEFAULT name, so C870-C874 do not
apply to an ASSOCIATE name of such a pointer: passing it to a dummy argument
without INTENT is not diagnosed. LASTPRIVATE of such a pointer is allowed,
since OpenMP updates it as if by pointer assignment.
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. Flang
reports the data-target case of C864 only through the optional
-Wpointer-to-undefinable warning and keeps that for these pointers, so the
NOTE 1 example compiles cleanly by default.
Intrinsic procedures, including intrinsic module procedures such as
C_F_POINTER that Flang implements as intrinsics, are exempt from C872 and
C874, since a literal C872 would reject `associated(p)`. The attribute is
not a procedure characteristic, so interfaces can drop it. The NOTE 2
diagnostic is not implemented, and contexts that Flang does not check for
any attribute, such as INQUIRE IOLENGTH=, stay unchecked.
Assisted-by: GitHub Copilot
---
flang/docs/ReleaseNotes.md | 18 ++
flang/examples/FeatureList/FeatureList.cpp | 2 +
.../include/flang/Evaluate/characteristics.h | 3 +
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 22 +-
flang/include/flang/Semantics/attr.h | 4 +-
flang/include/flang/Semantics/tools.h | 30 +++
flang/lib/Evaluate/characteristics.cpp | 5 +
flang/lib/Parser/Fortran-parsers.cpp | 11 +-
flang/lib/Parser/misc-parsers.h | 2 +
flang/lib/Parser/program-parsers.cpp | 4 +
flang/lib/Parser/unparse.cpp | 4 +
flang/lib/Semantics/check-allocate.cpp | 9 +
flang/lib/Semantics/check-call.cpp | 53 ++++
flang/lib/Semantics/check-declarations.cpp | 9 +
flang/lib/Semantics/check-omp-structure.cpp | 7 +
flang/lib/Semantics/definable.cpp | 23 ++
flang/lib/Semantics/pointer-assignment.cpp | 57 ++++-
flang/lib/Semantics/resolve-names.cpp | 5 +
flang/lib/Semantics/tools.cpp | 80 ++++++
flang/test/Parser/protected-target.f90 | 38 +++
.../OpenMP/protected-target-pointer.f90 | 116 +++++++++
.../test/Semantics/protected-target-call.f90 | 212 ++++++++++++++++
.../protected-target-declarations.f90 | 63 +++++
.../protected-target-definability.f90 | 230 ++++++++++++++++++
.../Semantics/protected-target-mod-use.f90 | 79 ++++++
flang/test/Semantics/protected-target-mod.f90 | 33 +++
.../Semantics/protected-target-pointer.f90 | 184 ++++++++++++++
28 files changed, 1293 insertions(+), 12 deletions(-)
create mode 100644 flang/test/Parser/protected-target.f90
create mode 100644 flang/test/Semantics/OpenMP/protected-target-pointer.f90
create mode 100644 flang/test/Semantics/protected-target-call.f90
create mode 100644 flang/test/Semantics/protected-target-declarations.f90
create mode 100644 flang/test/Semantics/protected-target-definability.f90
create mode 100644 flang/test/Semantics/protected-target-mod-use.f90
create mode 100644 flang/test/Semantics/protected-target-mod.f90
create mode 100644 flang/test/Semantics/protected-target-pointer.f90
diff --git a/flang/docs/ReleaseNotes.md b/flang/docs/ReleaseNotes.md
index 609ca499da396..bfeaf8ee8c908 100644
--- a/flang/docs/ReleaseNotes.md
+++ b/flang/docs/ReleaseNotes.md
@@ -169,6 +169,24 @@ page](https://llvm.org/releases/).
`SIMPLE` constraints, or give the pointer or dummy an explicit `PURE`
interface.
+- 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 for data
+ pointers and data pointer components. The target of such a pointer cannot
+ be defined through it, so assignment through the pointer, `DEALLOCATE`,
+ and `ALLOCATE` without `SOURCE=` are errors. In a pointer assignment or a
+ structure constructor, the pointer, or a part of its target designated
+ through the pointer, can be a data-target only for a `PROTECTED_TARGET`
+ pointer or pointer component. As an actual argument, except to an
+ intrinsic procedure or to an intrinsic module procedure that Flang
+ implements as one, such as `C_F_POINTER`, it can correspond only to a
+ `PROTECTED_TARGET` pointer dummy argument or a nonpointer `INTENT(IN)`
+ dummy argument. Following 8.5.16 NOTE 1, a `PROTECTED_TARGET` pointer may
+ be associated with an `INTENT(IN)` target without a diagnostic.
+ Associating it with a use-associated `PROTECTED` target by pointer
+ assignment or pointer initialization, which C864 forbids, is accepted by
+ default and gets the same optional warning as other pointers under
+ `-Wpointer-to-undefinable` or `-pedantic`.
+
## Build System Changes
## New Issues Found
diff --git a/flang/examples/FeatureList/FeatureList.cpp b/flang/examples/FeatureList/FeatureList.cpp
index c5bcff5ac6088..0955f08de29ba 100644
--- a/flang/examples/FeatureList/FeatureList.cpp
+++ b/flang/examples/FeatureList/FeatureList.cpp
@@ -605,6 +605,8 @@ struct NodeVisitor {
READ_FEATURE(ProgramUnit)
READ_FEATURE(Protected)
READ_FEATURE(ProtectedStmt)
+ READ_FEATURE(ProtectedTarget)
+ READ_FEATURE(ProtectedTargetStmt)
READ_FEATURE(ReadStmt)
READ_FEATURE(RealLiteralConstant)
READ_FEATURE(RealLiteralConstant::Real)
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 1ba0bf693c763..83b573eee59b9 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -262,6 +262,9 @@ struct DummyDataObject {
Attrs attrs;
common::IgnoreTKRSet ignoreTKR;
std::optional<common::CUDADataAttr> cudaDataAttr;
+ // F'2028 PROTECTED_TARGET; it is not a characteristic (15.3.2.2), so it is
+ // kept apart from attrs and does not affect compatibility or equality.
+ bool protectedTarget{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..22197b46aa1fa 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
@@ -374,6 +375,7 @@ EMPTY_CLASS(ErrorRecovery);
// intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
// pointer-stmt | protected-stmt | save-stmt | target-stmt |
// volatile-stmt | value-stmt | common-stmt | equivalence-stmt
+// F2028: protected-target-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,10 +998,12 @@ 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(Contiguous);
+EMPTY_CLASS(ProtectedTarget);
// CUDA-data-attr [( IMPLICIT )]
// The (IMPLICIT) qualifier marks an attribute that the compiler applied on the
// user's behalf (e.g. an unattributed ALLOCATABLE under -gpu=mem:managed)
@@ -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,9 @@ 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/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index d91a7d11a38c9..ce466655ae28f 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -178,6 +178,9 @@ inline bool IsIntentOut(const Symbol &symbol) {
inline bool IsProtected(const Symbol &symbol) {
return symbol.attrs().test(Attr::PROTECTED);
}
+inline bool IsProtectedTarget(const Symbol &symbol) {
+ return symbol.attrs().test(Attr::PROTECTED_TARGET);
+}
inline bool IsImpliedDoIndex(const Symbol &symbol) {
return symbol.owner().kind() == Scope::Kind::ImpliedDos;
}
@@ -360,6 +363,33 @@ const Symbol &BypassGeneric(const Symbol &);
using SomeExpr = evaluate::Expr<evaluate::SomeType>;
+// F'2028 8.5.16: The target of a data pointer with the PROTECTED_TARGET
+// attribute is not definable via that pointer. When a designator is such a
+// pointer, or designates its target or a subobject of its target, returns the
+// pointer; a reference to a function whose result is such a pointer returns
+// the result. Only the rightmost pointer in a data-ref matters, since the
+// target of a pointer component is not a subobject of its parent. In a
+// context that pertains to the pointer association status of the rightmost
+// pointer, that pointer is itself a subobject of its parent (F'2023 9.4.2p5),
+// so "p%next" is then a subobject of the target of "p". Such contexts
+// include the definition of that association, a pointer data-target, whose
+// association status the pointer object takes (F'2023 10.2.2.3p2), and an
+// actual argument for a pointer dummy argument. "isPointerDefinition" is
+// true for them, and the search then starts with that parent.
+// A RANK DEFAULT associate name has exactly the attributes of its selector
+// (F'2028 11.1.12.3p2), so it always stands for its selector. Other
+// associate names do not have the PROTECTED_TARGET attribute; they stand for
+// their selectors only in variable definition contexts, since the selector
+// is then in one too (F'2028 20.6.7(11), 11.1.3.3p5). So
+// "lookThroughAssociateNames" is true for the checks of definition contexts
+// (C866, C868, C869, 8.5.16p2) and false for C870-C874.
+const Symbol *FindProtectedTargetPointer(const Symbol &,
+ bool isPointerDefinition = false, bool lookThroughAssociateNames = true);
+const Symbol *FindProtectedTargetPointer(const evaluate::DataRef &,
+ bool isPointerDefinition = false, bool lookThroughAssociateNames = true);
+const Symbol *FindProtectedTargetPointer(const SomeExpr &,
+ bool isPointerDefinition = false, bool lookThroughAssociateNames = true);
+
bool ExprHasTypeCategory(
const SomeExpr &expr, const common::TypeCategory &type);
bool ExprTypeKindIsDefault(
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 4b05a25fd8f58..49a57fe4c78c9 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -443,6 +443,8 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
});
result->intent = GetIntent(symbol.attrs());
result->ignoreTKR = GetIgnoreTKR(symbol);
+ result->protectedTarget =
+ symbol.attrs().test(semantics::Attr::PROTECTED_TARGET);
if (object) {
result->cudaDataAttr = object->cudaDataAttr();
if (!result->cudaDataAttr &&
@@ -546,6 +548,9 @@ llvm::raw_ostream &DummyDataObject::Dump(llvm::raw_ostream &o) const {
if (cudaDataAttr) {
o << " cudaDataAttr: " << common::EnumToString(*cudaDataAttr);
}
+ if (protectedTarget) {
+ o << " PROTECTED_TARGET";
+ }
if (!ignoreTKR.empty()) {
ignoreTKR.Dump(o << ' ', common::EnumToString);
}
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 263ce9249a8b2..038087e6713fb 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -469,6 +469,7 @@ TYPE_PARSER(construct<DataComponentDefStmt>(declarationTypeSpec,
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// (F2028) PROTECTED_TARGET |
// CUDA-data-attr
TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(allocatable) ||
@@ -476,6 +477,7 @@ TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(contiguous) ||
construct<ComponentAttrSpec>("DIMENSION" >> componentArraySpec) ||
construct<ComponentAttrSpec>(pointer) ||
+ construct<ComponentAttrSpec>(protectedTarget) ||
extension<LanguageFeature::CUDA>(
construct<ComponentAttrSpec>(Parser<CUDADataAttrSpec>{})) ||
construct<ComponentAttrSpec>(recovery(
@@ -744,7 +746,9 @@ TYPE_PARSER(
// INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
// PROTECTED | RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
// VALUE | VOLATILE |
+// (F2028) PROTECTED_TARGET |
// CUDA-data-attr
+// PROTECTED_TARGET must be tried before PROTECTED, which matches its prefix.
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>(protectedTarget) ||
+ construct<AttrSpec>(protectedAttr) ||
construct<AttrSpec>("RANK" >>
construct<RankClause>(parenthesized(scalarIntConstantExpr))) ||
construct<AttrSpec>(save) ||
@@ -1050,6 +1055,10 @@ 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/misc-parsers.h b/flang/lib/Parser/misc-parsers.h
index 4a318e05bb4b8..355ca918b32e3 100644
--- a/flang/lib/Parser/misc-parsers.h
+++ b/flang/lib/Parser/misc-parsers.h
@@ -50,6 +50,8 @@ constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
+constexpr auto protectedTarget{
+ construct<ProtectedTarget>("PROTECTED_TARGET"_tok)};
constexpr auto save{construct<Save>("SAVE"_tok)};
template <typename A> common::IfNoLvalue<std::list<A>, A> singletonList(A &&x) {
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 08283a8be35e3..9e83c6d97b876 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -217,7 +217,10 @@ TYPE_CONTEXT_PARSER("specification construct"_en_US,
// intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
// pointer-stmt | protected-stmt | save-stmt | target-stmt |
// volatile-stmt | value-stmt | common-stmt | equivalence-stmt |
+// (F2028) protected-target-stmt |
// (CUDA) CUDA-attributes-stmt
+// The PROTECTED_TARGET statement must be tried before the PROTECTED
+// statement, which would otherwise take "_TARGET" as an entity name.
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..7a4b854103f7e 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -510,6 +510,15 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
"Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
return false;
}
+ // F'2028 C869. The selector of an associate name is taken to appear in
+ // its place as the allocate-object (F'2028 20.6.7(11)).
+ if (const Symbol *pointer{FindProtectedTargetPointer(*name_.symbol)};
+ pointer && !allocateInfo_.gotSource) {
+ context.Say(name_.source,
+ "An ALLOCATE statement with PROTECTED_TARGET pointer '%s' must have SOURCE="_err_en_US,
+ pointer->name());
+ 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..52ec51f960a2b 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -70,6 +70,13 @@ void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
+ if (const Symbol *pointer{FindProtectedTargetPointer(*expr,
+ /*isPointerDefinition=*/false,
+ /*lookThroughAssociateNames=*/false)}) {
+ messages.Say( // F'2028 C873
+ "The target of PROTECTED_TARGET pointer '%s' may not be an actual argument to a procedure with an implicit interface"_err_en_US,
+ pointer->name());
+ }
if (IsBOZLiteral(*expr)) {
messages.Say("BOZ argument %s requires an explicit interface"_err_en_US,
expr->AsFortran());
@@ -883,6 +890,52 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
}
}
+ // F'2028 C872 and C874. Intrinsic procedures are exempt, and so are the
+ // intrinsic module procedures that Flang implements as intrinsic
+ // procedures, such as C_F_POINTER. For C872 this departs from the text:
+ // read literally, it would reject a PROTECTED_TARGET pointer as an
+ // argument to ASSOCIATED, C_F_POINTER or any other of these procedures
+ // with a pointer dummy argument, since those dummy arguments do not have
+ // PROTECTED_TARGET. C874 needs no check for them: Flang gives each of
+ // their dummy arguments an INTENT, which is INTENT(IN) unless stated
+ // otherwise (F'2028 17.2.1p3).
+ // An INTENT(OUT) or INTENT(IN OUT) nonpointer dummy argument has already
+ // been diagnosed above, since the actual argument is not definable (C866).
+ // For a pointer dummy argument, a pointer component of the target, e.g.
+ // "p%next", is a subobject of the target (see
+ // FindProtectedTargetPointer()). With INTENT(OUT) or INTENT(IN OUT), that
+ // was diagnosed above as well.
+ if (scope && !intrinsic) {
+ const Symbol *pointer{FindProtectedTargetPointer(actual,
+ /*isPointerDefinition=*/false, /*lookThroughAssociateNames=*/false)};
+ if (dummyIsPointer) {
+ const Symbol *component{nullptr};
+ if (!pointer && actualIsPointer &&
+ (dummy.intent == common::Intent::Default ||
+ dummy.intent == common::Intent::In)) {
+ pointer = FindProtectedTargetPointer(actual,
+ /*isPointerDefinition=*/true, /*lookThroughAssociateNames=*/false);
+ component = evaluate::GetLastSymbol(actual);
+ }
+ if (pointer && !dummy.protectedTarget &&
+ (actualIsPointer || dummy.intent == common::Intent::In)) {
+ if (component) {
+ messages.Say(
+ "Pointer component '%s' of the target of PROTECTED_TARGET pointer '%s' may not be associated with POINTER %s, which does not have the PROTECTED_TARGET attribute"_err_en_US,
+ component->name(), pointer->name(), dummyName);
+ } else {
+ messages.Say(
+ "The target of PROTECTED_TARGET pointer '%s' may not be associated with POINTER %s, which does not have the PROTECTED_TARGET attribute"_err_en_US,
+ pointer->name(), dummyName);
+ }
+ }
+ } else if (pointer && dummy.intent == common::Intent::Default) {
+ messages.Say(
+ "The target of PROTECTED_TARGET pointer '%s' may not be associated with %s, which does not have the INTENT(IN) attribute"_err_en_US,
+ pointer->name(), dummyName);
+ }
+ }
+
// An INTENT(IN) dummy argument must not be defined during the invocation
// and execution of its procedure (F'2023 8.5.10 p2), but a dummy argument
// with no INTENT attribute may be defined by its procedure. Passing the
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 2abefd381850a..91343e917ab14 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -347,6 +347,15 @@ void CheckHelper::Check(const Symbol &symbol) {
"A PROTECTED entity may not be in a common block"_err_en_US);
}
}
+ if (IsProtectedTarget(symbol)) {
+ if (!IsObjectPointer(&symbol)) { // F'2028 C781, C8109, 8.5.16p1
+ messages_.Say(
+ "A PROTECTED_TARGET entity must be a data pointer"_err_en_US);
+ } else if (FindCommonBlockContaining(symbol)) { // F'2028 C867
+ messages_.Say(
+ "A PROTECTED_TARGET pointer 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..a72ac62f62e3b 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -6184,6 +6184,13 @@ void OmpStructureChecker::CheckDefinableObjects(
if (!IsVariableListItem(*symbol)) {
continue;
}
+ if (clause == llvm::omp::Clause::OMPC_lastprivate && IsPointer(*symbol) &&
+ FindProtectedTargetPointer(*symbol)) {
+ // A pointer list item is updated as if by pointer assignment
+ // (OpenMP 5.2 5.4.5), which does not define the target of a
+ // PROTECTED_TARGET pointer (F2028 8.5.16).
+ continue;
+ }
if (auto msg{WhyNotDefinable(source, context_.FindScope(source),
DefinabilityFlags{}, *symbol)}) {
context_
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index d6a654683001f..18752012a88cb 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -28,6 +28,14 @@ static bool IsPointerDummyOfPureFunction(const Symbol &x) {
x.owner().symbol() && IsFunction(*x.owner().symbol());
}
+// F'2028 C866 and 8.5.16p2: the target of a PROTECTED_TARGET pointer, and
+// any subobject of that target, is not definable via that pointer.
+static parser::Message WhyProtectedTargetIsNotDefinable(
+ parser::CharBlock at, const Symbol &pointer) {
+ return BlameSymbol(
+ at, "'%s' has the PROTECTED_TARGET attribute"_en_US, pointer);
+}
+
// See C1594, first paragraph. These conditions enable checks on both
// left-hand and right-hand sides in various circumstances.
const char *WhyBaseObjectIsSuspicious(const Symbol &x, const Scope &scope) {
@@ -258,6 +266,10 @@ 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))}) {
+ return WhyProtectedTargetIsNotDefinable(at, *pointer);
+ }
if (auto whyNotLast{
WhyNotDefinableLast(at, scope, flags, dataRef.GetLastSymbol())}) {
if (whyNotLast->IsFatal() || !whyNotBase) {
@@ -273,6 +285,10 @@ 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))}) {
+ return WhyProtectedTargetIsNotDefinable(at, *pointer);
+ }
if (auto whyNotLast{WhyNotDefinableLast(at, scope, flags, original)}) {
if (whyNotLast->IsFatal() || !whyNotBase) {
return whyNotLast;
@@ -412,6 +428,10 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
}
if (const auto *component{procDesignator->GetComponent()}) {
flags.reset(DefinabilityFlag::PointerDefinition);
+ if (const Symbol *pointer{
+ FindProtectedTargetPointer(component->base())}) {
+ return WhyProtectedTargetIsNotDefinable(at, *pointer);
+ }
return WhyNotDefinableBase(at, scope, flags,
component->base().GetFirstSymbol(), false,
DefinesComponentPointerTarget(component->base(), flags));
@@ -425,6 +445,9 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
} else if (!evaluate::IsVariable(expr)) {
return parser::Message{
at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
+ } else if (const Symbol *pointer{FindProtectedTargetPointer(expr)}) {
+ // a reference to a function with a PROTECTED_TARGET pointer result
+ return WhyProtectedTargetIsNotDefinable(at, *pointer);
}
return portabilityWarning;
}
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..9d413dbdc67ca 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -50,10 +50,14 @@ class PointerAssignmentChecker {
set_lhsType(TypeAndShape::Characterize(lhs, foldingContext_));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
+ set_isProtectedTarget(FindProtectedTargetPointer(lhs,
+ /*isPointerDefinition=*/false,
+ /*lookThroughAssociateNames=*/false) != nullptr);
}
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_isContiguous(bool);
PointerAssignmentChecker &set_isVolatile(bool);
+ PointerAssignmentChecker &set_isProtectedTarget(bool);
PointerAssignmentChecker &set_isBoundsRemapping(bool);
PointerAssignmentChecker &set_isAssumedRank(bool);
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
@@ -92,6 +96,7 @@ class PointerAssignmentChecker {
bool characterizedProcedure_{false};
bool isContiguous_{false};
bool isVolatile_{false};
+ bool isProtectedTarget_{false};
bool isBoundsRemapping_{false};
bool isAssumedRank_{false};
bool isRHSPointerActualArgument_{false};
@@ -117,6 +122,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isProtectedTarget(
+ bool isProtectedTarget) {
+ isProtectedTarget_ = isProtectedTarget;
+ return *this;
+}
+
PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
bool isBoundsRemapping) {
isBoundsRemapping_ = isBoundsRemapping;
@@ -207,6 +218,32 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
if (lhs_ && IsProcedure(*lhs_)) {
return true;
}
+ const Symbol *protectedTarget{FindProtectedTargetPointer(rhs,
+ /*isPointerDefinition=*/false, /*lookThroughAssociateNames=*/false)};
+ const Symbol *pointer{protectedTarget};
+ const Symbol *component{nullptr};
+ if (!pointer && lhs_ && evaluate::IsObjectPointer(rhs)) {
+ // e.g. "p%next" (see FindProtectedTargetPointer())
+ pointer = FindProtectedTargetPointer(rhs, /*isPointerDefinition=*/true,
+ /*lookThroughAssociateNames=*/false);
+ component = GetLastSymbol(rhs);
+ }
+ if (pointer && lhs_ && !isProtectedTarget_) { // F'2028 C870, C871
+ parser::Message *msg{nullptr};
+ if (component) {
+ msg = Say(
+ "Pointer component '%s' of the target of PROTECTED_TARGET pointer '%s' may not be a data-target for %s, which does not have the PROTECTED_TARGET attribute"_err_en_US,
+ component->name(), pointer->name(), description_);
+ } else {
+ msg = Say(
+ "The target of PROTECTED_TARGET pointer '%s' may not be associated with %s, which does not have the PROTECTED_TARGET attribute"_err_en_US,
+ pointer->name(), description_);
+ }
+ if (msg) {
+ evaluate::AttachDeclaration(msg, *pointer);
+ }
+ 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,9 +280,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)}) {
+ // Warn about undefinable data targets. F'2028 C864, a data-target or
+ // initial-data-target (not an actual argument) whose base object is
+ // PROTECTED, is reported only as this optional warning, for every pointer;
+ // WhyNotDefinable() reports such an object when it is use-associated and
+ // not a pointer. A PROTECTED_TARGET pointer keeps the warning for that
+ // case, which also lets the "p => x" of 8.5.16 NOTE 1 compile by default.
+ // It gets no warning for other undefinable targets, since it cannot
+ // define its target (F'2028 C866, 8.5.16p2).
+ const Symbol *base{GetFirstSymbol(rhs)};
+ if (protectedTarget) {
+ // F'2028 C870-C872 apply instead
+ } else if (isProtectedTarget_ &&
+ !(lhs_ && base && IsProtected(GetAssociationRoot(*base)))) {
+ // not F'2028 C864
+ } else 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)));
@@ -619,6 +669,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.protectedTarget)
.set_isAssumedRank(isAssumedRank)
.set_isRHSPointerActualArgument(isPointerActualArgument)
.set_ignoreTKR(lhs.ignoreTKR)
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/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 48ff27f214649..80390a864ed10 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -382,6 +382,86 @@ const Symbol &BypassGeneric(const Symbol &symbol) {
return symbol;
}
+static const Symbol *FindProtectedTargetPointer(
+ const evaluate::Component &component, bool isPointerDefinition,
+ bool lookThroughAssociateNames) {
+ const Symbol &symbol{component.GetLastSymbol()};
+ if (!isPointerDefinition && IsPointer(symbol)) {
+ return IsProtectedTarget(symbol) ? &symbol : nullptr;
+ } else {
+ return FindProtectedTargetPointer(
+ component.base(), false, lookThroughAssociateNames);
+ }
+}
+
+const Symbol *FindProtectedTargetPointer(const Symbol &original,
+ bool isPointerDefinition, bool lookThroughAssociateNames) {
+ const Symbol &ultimate{original.GetUltimate()};
+ if (const auto *assoc{ultimate.detailsIf<AssocEntityDetails>()}; assoc &&
+ (lookThroughAssociateNames || assoc->IsAssumedRank()) &&
+ (!isPointerDefinition || IsPointer(ultimate))) {
+ // An associate name that stands for its selector may be a pointer
+ // (SELECT RANK), so this is checked before IsPointer().
+ if (const auto &expr{assoc->expr()}) {
+ return FindProtectedTargetPointer(
+ *expr, isPointerDefinition, lookThroughAssociateNames);
+ }
+ } else if (isPointerDefinition) {
+ // a whole pointer may be associated, nullified, etc.
+ } else if (IsPointer(ultimate) && IsProtectedTarget(ultimate)) {
+ return &original;
+ }
+ return nullptr;
+}
+
+const Symbol *FindProtectedTargetPointer(const evaluate::DataRef &dataRef,
+ bool isPointerDefinition, bool lookThroughAssociateNames) {
+ return common::visit(
+ common::visitors{
+ [&](const evaluate::SymbolRef &symbol) {
+ return FindProtectedTargetPointer(
+ *symbol, isPointerDefinition, lookThroughAssociateNames);
+ },
+ [&](const evaluate::Component &component) {
+ return FindProtectedTargetPointer(
+ component, isPointerDefinition, lookThroughAssociateNames);
+ },
+ [&](const evaluate::ArrayRef &arrayRef) {
+ // An array element or section is not itself a pointer.
+ if (const auto *component{arrayRef.base().UnwrapComponent()}) {
+ return FindProtectedTargetPointer(
+ *component, false, lookThroughAssociateNames);
+ } else {
+ return FindProtectedTargetPointer(arrayRef.base().GetLastSymbol(),
+ false, lookThroughAssociateNames);
+ }
+ },
+ [&](const evaluate::CoarrayRef &coarrayRef) {
+ return FindProtectedTargetPointer(coarrayRef.base(),
+ isPointerDefinition, lookThroughAssociateNames);
+ },
+ },
+ dataRef.u);
+}
+
+const Symbol *FindProtectedTargetPointer(const SomeExpr &expr,
+ bool isPointerDefinition, bool lookThroughAssociateNames) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
+ return FindProtectedTargetPointer(
+ *dataRef, isPointerDefinition, lookThroughAssociateNames);
+ } else if (!isPointerDefinition) {
+ if (const auto *procRef{evaluate::UnwrapProcedureRef(expr)}) {
+ if (const Symbol *proc{procRef->proc().GetSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*proc)};
+ result && IsPointer(*result) && IsProtectedTarget(*result)) {
+ return result;
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
bool ExprHasTypeCategory(
const SomeExpr &expr, const common::TypeCategory &type) {
auto dynamicType{expr.GetType()};
diff --git a/flang/test/Parser/protected-target.f90 b/flang/test/Parser/protected-target.f90
new file mode 100644
index 0000000000000..936e78a3d84d1
--- /dev/null
+++ b/flang/test/Parser/protected-target.f90
@@ -0,0 +1,38 @@
+! 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 of the PROTECTED_TARGET attribute and statement
+! (F2028 R802, R749, R863)
+
+module m
+ !CHECK: TYPE :: t
+ !CHECK: INTEGER, POINTER, PROTECTED_TARGET :: c
+ !TREE: ComponentAttrSpec -> Pointer
+ !TREE: ComponentAttrSpec -> ProtectedTarget
+ type :: t
+ integer, pointer, protected_target :: c
+ end type
+ !CHECK: REAL, POINTER, PROTECTED_TARGET :: p1
+ !TREE: AttrSpec -> Pointer
+ !TREE: AttrSpec -> ProtectedTarget
+ real, pointer, protected_target :: p1
+ !CHECK: REAL, PROTECTED_TARGET, POINTER :: p2
+ real, protected_target, pointer :: p2
+ !CHECK: REAL, POINTER :: p3, p4, p5
+ real, pointer :: p3, p4, p5
+ !CHECK: PROTECTED_TARGET :: p3
+ !TREE: OtherSpecificationStmt -> ProtectedTargetStmt -> Name = 'p3'
+ protected_target :: p3
+ !CHECK: PROTECTED_TARGET :: p4, p5
+ !TREE: OtherSpecificationStmt -> ProtectedTargetStmt -> Name = 'p4'
+ !TREE-NEXT: Name = 'p5'
+ protected_target p4, p5
+ !CHECK: REAL, PROTECTED, TARGET :: x
+ !TREE: AttrSpec -> Protected
+ real, protected, target :: x
+ !CHECK: REAL, TARGET :: y
+ !CHECK: PROTECTED :: y
+ !TREE: OtherSpecificationStmt -> ProtectedStmt -> Name = 'y'
+ real, target :: y
+ protected y
+end
diff --git a/flang/test/Semantics/OpenMP/protected-target-pointer.f90 b/flang/test/Semantics/OpenMP/protected-target-pointer.f90
new file mode 100644
index 0000000000000..219098d8dcce5
--- /dev/null
+++ b/flang/test/Semantics/OpenMP/protected-target-pointer.f90
@@ -0,0 +1,116 @@
+! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp
+! A PROTECTED_TARGET pointer (F'2028 8.5.16) may appear in a clause that
+! updates a pointer list item by pointer assignment, such as LASTPRIVATE,
+! COPYPRIVATE and COPYIN, but not where its target would be defined.
+
+module m
+ integer, pointer, protected_target :: mp
+end
+
+subroutine pointer_assignment_clauses(p, q, r)
+ integer, pointer, protected_target :: p
+ integer, pointer, protected_target, intent(in) :: q
+ integer, pointer :: r
+ integer, pointer, protected_target, save :: tp
+ integer, target :: x(10)
+ integer :: i
+ !$omp threadprivate(tp)
+
+ !$omp parallel do lastprivate(p)
+ do i = 1, 10
+ p => x(i)
+ end do
+ !$omp end parallel do
+
+ !$omp parallel do lastprivate(r)
+ do i = 1, 10
+ r => x(i)
+ end do
+ !$omp end parallel do
+
+ !ERROR: Pointer 'q' with the INTENT(IN) attribute may not appear in a LASTPRIVATE clause
+ !$omp parallel do lastprivate(q)
+ do i = 1, 10
+ end do
+ !$omp end parallel do
+
+ !$omp parallel private(p)
+ !$omp single
+ p => x(1)
+ !$omp end single copyprivate(p)
+ !$omp end parallel
+
+ !$omp parallel copyin(tp)
+ print *, tp
+ !$omp end parallel
+
+ !$omp parallel do firstprivate(p)
+ do i = 1, 10
+ print *, p
+ end do
+ !$omp end parallel do
+end
+
+subroutine associated_pointers
+ use m
+ integer, pointer, protected_target :: hp
+ integer, target :: x(10)
+ integer :: i
+ !$omp parallel do lastprivate(mp)
+ do i = 1, 10
+ mp => x(i)
+ end do
+ !$omp end parallel do
+ call inner
+ contains
+ subroutine inner
+ integer :: j
+ !$omp parallel do lastprivate(hp)
+ do j = 1, 10
+ hp => x(j)
+ end do
+ !$omp end parallel do
+ end
+end
+
+subroutine select_rank(ar)
+ integer, pointer, protected_target :: ar(..)
+ integer, target :: x(10)
+ integer :: i
+ select rank (r => ar)
+ rank (1)
+ !ERROR: Variable 'r' in ASSOCIATE cannot be in a LASTPRIVATE clause
+ !$omp parallel do lastprivate(r)
+ do i = 1, 10
+ r => x(i:i)
+ end do
+ !$omp end parallel do
+ end select
+end
+
+subroutine target_definitions(p)
+ integer, pointer, protected_target :: p
+ integer :: i
+
+ !ERROR: Variable 'p' on the REDUCTION clause is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ !$omp parallel do reduction(+:p)
+ do i = 1, 10
+ end do
+ !$omp end parallel do
+
+ !$omp parallel do lastprivate(p)
+ do i = 1, 10
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ p = i
+ end do
+ !$omp end parallel do
+
+ !$omp parallel
+ !$omp atomic update
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ p = p + 1
+ !$omp end parallel
+end
diff --git a/flang/test/Semantics/protected-target-call.f90 b/flang/test/Semantics/protected-target-call.f90
new file mode 100644
index 0000000000000..0ea5f092df33f
--- /dev/null
+++ b/flang/test/Semantics/protected-target-call.f90
@@ -0,0 +1,212 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Actual arguments that are PROTECTED_TARGET pointers or subobjects of their
+! targets (F'2028 C872, C873, C874).
+
+module m
+ type :: t
+ integer :: n
+ integer, pointer :: next
+ contains
+ procedure :: in_method, method
+ end type
+ interface gen
+ module procedure gen_int, gen_real
+ end interface
+ contains
+ subroutine in_method(this)
+ class(t), intent(in) :: this
+ end
+ subroutine method(this)
+ class(t) :: this
+ end
+ subroutine ptr_pt(d)
+ integer, pointer, protected_target :: d
+ end
+ subroutine ptr_pt_out(d)
+ integer, pointer, protected_target, intent(out) :: d
+ end
+ subroutine ptr_pt_in_array(d)
+ integer, pointer, protected_target, intent(in) :: d(:)
+ end
+ subroutine ptr(d)
+ integer, pointer :: d
+ end
+ subroutine ptr_in(d)
+ integer, pointer, intent(in) :: d
+ end
+ subroutine ptr_inout(d)
+ integer, pointer, intent(in out) :: d
+ end
+ subroutine ptr_in_array(d)
+ integer, pointer, intent(in) :: d(:)
+ end
+ subroutine obj_in(d)
+ integer, intent(in) :: d
+ end
+ subroutine obj(d)
+ integer :: d
+ end
+ subroutine obj_value(d)
+ integer, value :: d
+ end
+ subroutine obj_out(d)
+ integer, intent(out) :: d
+ end
+ subroutine obj_inout(d)
+ integer, intent(in out) :: d
+ end
+ subroutine gen_int(d)
+ integer :: d
+ end
+ subroutine gen_real(d)
+ real :: d
+ end
+ subroutine ar_ptr(d)
+ integer, pointer :: d(..)
+ end
+ subroutine ar_ptr_pt(d)
+ integer, pointer, protected_target :: d(..)
+ end
+ subroutine ar_obj(d)
+ integer :: d(..)
+ end
+ subroutine ar_obj_in(d)
+ integer, intent(in) :: d(..)
+ end
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ allocate(r, source=1)
+ end
+end
+
+subroutine calls(p, pa, pt, w)
+ use m
+ use iso_c_binding, only: c_ptr, c_f_pointer
+ integer, pointer, protected_target :: p, pa(:)
+ type(t), pointer, protected_target :: pt
+ integer, pointer :: w
+ real, pointer, protected_target :: pr
+ type(c_ptr) :: cp
+ procedure(ptr_pt), pointer :: proc_pt
+ procedure(ptr), pointer :: proc
+ call ptr_pt(p)
+ call ptr_pt_out(p)
+ call ptr_pt_in_array(pa(1:2))
+ call ptr_pt(w)
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
+ call ptr(p)
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
+ call ptr_in(p)
+ !ERROR: The target of PROTECTED_TARGET pointer 'pa' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
+ call ptr_in_array(pa(1:2))
+ !ERROR: The target of PROTECTED_TARGET pointer 'r' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
+ call ptr_in(get())
+ call obj_in(p)
+ call obj_in(pa(1))
+ call obj_in(pt%n)
+ call obj_in(get())
+ call obj((p))
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with dummy argument 'd=', which does not have the INTENT(IN) attribute
+ call obj(p)
+ !ERROR: The target of PROTECTED_TARGET pointer 'pa' may not be associated with dummy argument 'd=', which does not have the INTENT(IN) attribute
+ call obj(pa(2))
+ !ERROR: The target of PROTECTED_TARGET pointer 'pt' may not be associated with dummy argument 'd=', which does not have the INTENT(IN) attribute
+ call obj(pt%n)
+ !ERROR: The target of PROTECTED_TARGET pointer 'r' may not be associated with dummy argument 'd=', which does not have the INTENT(IN) attribute
+ call obj(get())
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with dummy argument 'd=', which does not have the INTENT(IN) attribute
+ call obj_value(p)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'd=' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ call obj_out(p)
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'd=' is not definable
+ !BECAUSE: 'pa' has the PROTECTED_TARGET attribute
+ call obj_inout(pa(1))
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with dummy argument 'd=', which does not have the INTENT(IN) attribute
+ call gen(p)
+ ! A pointer component of the target is a subobject of the target when the
+ ! dummy argument is a pointer, but its own target is not.
+ call obj(pt%next)
+ !ERROR: Pointer component 'next' of the target of PROTECTED_TARGET pointer 'pt' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
+ call ptr(pt%next)
+ !ERROR: Pointer component 'next' of the target of PROTECTED_TARGET pointer 'pt' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
+ call ptr_in(pt%next)
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'd=' is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ call ptr_inout(pt%next)
+ call ptr_pt(pt%next)
+ call pt%in_method()
+ !ERROR: The target of PROTECTED_TARGET pointer 'pt' may not be associated with dummy argument 'this=', which does not have the INTENT(IN) attribute
+ call pt%method()
+ proc_pt => ptr_pt
+ call proc_pt(p)
+ proc => ptr
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
+ call proc(p)
+ ! Intrinsic procedures
+ print *, associated(p), associated(pa, pa), size(pa), lbound(pa), kind(p)
+ print *, sum(pa), maxval(pa), loc(p)
+ call c_f_pointer(cp, p)
+ ! INTENT(OUT) arguments of intrinsic procedures are still subject to C866.
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'harvest=' is not definable
+ !BECAUSE: 'pr' has the PROTECTED_TARGET attribute
+ call random_number(pr)
+end
+
+subroutine associate_names(p, ar)
+ use m
+ integer, pointer, protected_target :: p, ar(..)
+ external :: ext
+ ! Accepted: neither an ASSOCIATE name (F'2028 11.1.3.3p1) nor a RANK(n)
+ ! associate name (11.1.12.3p3) has the PROTECTED_TARGET attribute.
+ associate (a => p)
+ call obj(a)
+ call ptr_in(a)
+ call ext(a)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'd=' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ call obj_out(a)
+ end associate
+ select rank (r => ar)
+ rank (0)
+ call obj_in(r)
+ call ptr_pt(r)
+ call obj(r)
+ call ptr(r)
+ call ptr_inout(r)
+ call ext(r)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'd=' is not definable
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ call obj_out(r)
+ rank default
+ ! A RANK DEFAULT associate name has exactly the attributes of its
+ ! selector (F'2028 11.1.12.3p2).
+ call ar_obj_in(r)
+ call ar_ptr_pt(r)
+ !ERROR: The target of PROTECTED_TARGET pointer 'ar' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
+ call ar_ptr(r)
+ !ERROR: The target of PROTECTED_TARGET pointer 'ar' may not be associated with dummy argument 'd=', which does not have the INTENT(IN) attribute
+ call ar_obj(r)
+ !ERROR: The target of PROTECTED_TARGET pointer 'ar' may not be an actual argument to a procedure with an implicit interface
+ !ERROR: Assumed rank argument 'r' requires an explicit interface
+ call ext(r)
+ end select
+end
+
+subroutine implicit_interface(p, pa, dp)
+ integer, pointer, protected_target :: p, pa(:)
+ external :: ext, dp
+ procedure(), pointer :: ip
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be an actual argument to a procedure with an implicit interface
+ call ext(p)
+ !ERROR: The target of PROTECTED_TARGET pointer 'pa' may not be an actual argument to a procedure with an implicit interface
+ call ext(pa(1))
+ !ERROR: The target of PROTECTED_TARGET pointer 'pa' may not be an actual argument to a procedure with an implicit interface
+ print *, ifun(pa)
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be an actual argument to a procedure with an implicit interface
+ call dp(p)
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be an actual argument to a procedure with an implicit interface
+ call ip(p)
+ call ext((p))
+ call ext(p + 1)
+end
diff --git a/flang/test/Semantics/protected-target-declarations.f90 b/flang/test/Semantics/protected-target-declarations.f90
new file mode 100644
index 0000000000000..a0ff7c6808253
--- /dev/null
+++ b/flang/test/Semantics/protected-target-declarations.f90
@@ -0,0 +1,63 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Declarations with the PROTECTED_TARGET attribute (F'2028 8.5.16, 8.6.14)
+
+module m1
+ real, target :: x
+ real, pointer, protected_target :: p1 => x
+ real, pointer :: p2, p3
+ protected_target :: p2
+ protected_target p3
+ real, protected_target :: p4
+ pointer :: p4
+ real, pointer, protected, protected_target :: p5
+ type :: t
+ real, pointer, protected_target :: c1
+ real, pointer, protected_target :: c2(:)
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real, protected_target :: c3
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real, allocatable, protected_target :: c4
+ end type
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real, protected_target :: n1
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real, target, protected_target :: n2
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real :: n3
+ protected_target :: n3
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ real, allocatable, protected_target :: n4
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ procedure(f), pointer :: pp
+ protected_target :: pp
+ contains
+ function f()
+ real, pointer, protected_target :: f
+ f => x
+ end
+ function g() result(r)
+ real, pointer :: r
+ protected_target :: r
+ r => x
+ end
+ subroutine s1(d1, d2)
+ real, pointer, protected_target, intent(in) :: d1
+ real, pointer, protected_target :: d2
+ end
+end
+
+subroutine s2
+ use m1
+ !ERROR: Cannot change PROTECTED_TARGET attribute on use-associated 'x'
+ protected_target :: x
+end
+
+subroutine s3
+ !ERROR: A PROTECTED_TARGET pointer may not be in a common block
+ real, pointer, protected_target :: p
+ !ERROR: A PROTECTED_TARGET pointer may not be in a common block
+ integer, pointer, protected_target :: q
+ real, pointer :: r
+ common /blk/ p, r
+ common q
+end
diff --git a/flang/test/Semantics/protected-target-definability.f90 b/flang/test/Semantics/protected-target-definability.f90
new file mode 100644
index 0000000000000..24a89f998166f
--- /dev/null
+++ b/flang/test/Semantics/protected-target-definability.f90
@@ -0,0 +1,230 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! The target of a PROTECTED_TARGET pointer, and any subobject of that target,
+! is not definable via that pointer (F'2028 C866, C868, C869, 8.5.16p2).
+
+module m
+ type :: t
+ integer :: n
+ integer :: a(2)
+ integer, allocatable :: al
+ integer, pointer :: next
+ procedure(), nopass, pointer :: pp
+ end type
+ type :: wrap
+ integer, pointer, protected_target :: q
+ end type
+ interface assignment(=)
+ module procedure assign_int
+ end interface
+ contains
+ subroutine assign_int(a, b)
+ type(t), intent(in out) :: a
+ integer, intent(in) :: b
+ end
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ allocate(r, source=1)
+ end
+end
+
+subroutine definitions(p, pa, pt, pc, pz, w, x, y)
+ use m
+ integer, pointer, protected_target :: p, pa(:)
+ type(t), pointer, protected_target :: pt
+ character(4), pointer, protected_target :: pc
+ complex, pointer, protected_target :: pz
+ type(wrap) :: w
+ integer, target :: x
+ integer, pointer :: y
+ integer :: j
+ external :: ext
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ p = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ if (.false.) p = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pa' has the PROTECTED_TARGET attribute
+ pa(1) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pa' has the PROTECTED_TARGET attribute
+ pa(1:2) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ pt%n = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ pt%a(2) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ pt%al = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pc' has the PROTECTED_TARGET attribute
+ pc(1:2) = 'ab'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pz' has the PROTECTED_TARGET attribute
+ pz%re = 1.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'q' has the PROTECTED_TARGET attribute
+ w%q = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'r' has the PROTECTED_TARGET attribute
+ get() = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'a=' is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ pt = 1
+ !ERROR: Input variable 'p' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ read *, p
+ !ERROR: IOSTAT variable 'p' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ read(*, *, iostat=p) j
+ !ERROR: Internal file variable 'pc' is not definable
+ !BECAUSE: 'pc' has the PROTECTED_TARGET attribute
+ write(pc, '(i4)') j
+ !ERROR: 'p' may not be used as a DO variable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ do p = 1, 2
+ end do
+ !ERROR: 'p' has the PROTECTED_TARGET attribute
+ print *, (j, p = 1, 2)
+ associate (a => p, b => pt%a)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ a = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ b(1) = 1
+ end associate
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ allocate(pt%al)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ deallocate(pt%al)
+ ! A pointer component in the target is part of the target.
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ pt%next => x
+ !ERROR: 'next' may not appear in NULLIFY
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ nullify(pt%next)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ pt%pp => ext
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ allocate(pt%next)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'pt' has the PROTECTED_TARGET attribute
+ deallocate(pt%next)
+ ! The target of that component is not part of the target, so it may be
+ ! defined.
+ pt%next = 1
+ ! The association of a PROTECTED_TARGET pointer may change.
+ p => x
+ p => y
+ nullify(p)
+ pa => null()
+ w%q => x
+ ! The target can still be defined other than via the pointer.
+ x = 2
+ y => x
+ y = 3
+ print *, p, pa, pt%n, pc, pz, w%q, get()
+end
+
+subroutine allocations(p, pa, w)
+ use m
+ integer, pointer, protected_target :: p, pa(:)
+ type(wrap) :: w
+ !ERROR: An ALLOCATE statement with PROTECTED_TARGET pointer 'p' must have SOURCE=
+ allocate(p)
+ !ERROR: An ALLOCATE statement with PROTECTED_TARGET pointer 'pa' must have SOURCE=
+ allocate(pa(2))
+ !ERROR: An ALLOCATE statement with PROTECTED_TARGET pointer 'pa' must have SOURCE=
+ allocate(pa, mold=[1, 2])
+ !ERROR: An ALLOCATE statement with PROTECTED_TARGET pointer 'q' must have SOURCE=
+ allocate(w%q)
+ allocate(p, source=1)
+ allocate(pa, source=[1, 2])
+ allocate(w%q, source=p)
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ deallocate(p)
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'q' has the PROTECTED_TARGET attribute
+ deallocate(w%q)
+end
+
+subroutine intent_in(p)
+ integer, pointer, protected_target, intent(in) :: p
+ integer, target :: x
+ print *, p
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ p => x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ p = 1
+end
+
+subroutine select(up)
+ class(*), pointer, protected_target :: up
+ select type (a => up)
+ type is (integer)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'up' has the PROTECTED_TARGET attribute
+ a = 1
+ end select
+end
+
+subroutine select_rank(ar, x)
+ integer, pointer, protected_target :: ar(..)
+ integer, target :: x(2)
+ ! In a variable definition context, an associate name stands for its
+ ! selector (F'2028 20.6.7(11)).
+ select rank (r => ar)
+ rank (0)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ r = 1
+ !ERROR: Input variable 'r' is not definable
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ read *, r
+ rank (1)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ r(1) = 1
+ !ERROR: An ALLOCATE statement with PROTECTED_TARGET pointer 'ar' must have SOURCE=
+ allocate(r(2))
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ deallocate(r)
+ ! Accepted: F'2028 11.1.3.3p5 forbids these pointer association contexts
+ ! for the associate name, but not as a constraint.
+ allocate(r, source=x)
+ nullify(r)
+ r => x
+ rank default
+ nullify(r)
+ select rank (s => r)
+ rank (2)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ s(1, 1) = 1
+ end select
+ end select
+end
+
+subroutine namelist_read(p)
+ integer, pointer, protected_target :: p
+ namelist /nml/ p
+ !ERROR: NAMELIST input group must not contain undefinable item 'p'
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute
+ read(*, nml=nml)
+ write(*, nml=nml)
+end
diff --git a/flang/test/Semantics/protected-target-mod-use.f90 b/flang/test/Semantics/protected-target-mod-use.f90
new file mode 100644
index 0000000000000..99dfd134525a1
--- /dev/null
+++ b/flang/test/Semantics/protected-target-mod-use.f90
@@ -0,0 +1,79 @@
+! RUN: rm -rf %t && split-file %s %t
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/m.f90
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/ok.f90 2>&1 | FileCheck --allow-empty --check-prefix=OK %s
+! RUN: %flang_fc1 -fsyntax-only -pedantic -J%t %t/ok.f90 2>&1 | FileCheck --check-prefix=PEDANTIC %s
+! RUN: not %flang_fc1 -fsyntax-only -J%t %t/bad.f90 2>&1 | FileCheck %s
+
+! PROTECTED_TARGET survives a module file, so its constraints apply to the
+! entities of a module that is read back from its .mod file.
+
+!--- m.f90
+module protected_target_mod_use_m
+ integer, target, protected :: px = 1
+ integer, pointer, protected_target :: mp
+ type :: t
+ integer, pointer, protected_target :: c
+ end type
+ contains
+ subroutine take_pt(d)
+ integer, pointer, protected_target :: d
+ end
+ subroutine take_ptr(d)
+ integer, pointer :: d
+ end
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => px
+ end
+end
+
+!--- ok.f90
+subroutine ok
+ use protected_target_mod_use_m
+ integer, pointer, protected_target :: q
+ type(t) :: a
+ mp => px
+ q => mp
+ q => get()
+ a = t(mp)
+ call take_pt(mp)
+ print *, mp, q, a%c
+end
+
+!--- bad.f90
+subroutine bad
+ use protected_target_mod_use_m
+ integer, pointer :: w
+ type(t) :: a
+ mp = 2
+ w => mp
+ w => get()
+ a%c = 3
+ deallocate(mp)
+ contains
+ subroutine inner(q)
+ integer, pointer, protected_target :: q
+ call take_ptr(q)
+ end
+end
+
+! OK-NOT: error
+! OK-NOT: warning
+
+! F'2028 C864 forbids "mp => px", although 8.5.16 NOTE 1 shows the equivalent
+! as valid; it gets only the optional warning.
+! PEDANTIC-NOT: error
+! PEDANTIC: warning: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+! PEDANTIC: because: 'px' is protected in this scope
+! PEDANTIC-NOT: error
+! PEDANTIC-NOT: warning
+
+! CHECK: error: Left-hand side of assignment is not definable
+! CHECK: because: 'mp' has the PROTECTED_TARGET attribute
+! CHECK: error: The target of PROTECTED_TARGET pointer 'mp' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+! CHECK: error: The target of PROTECTED_TARGET pointer 'r' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+! CHECK: error: Left-hand side of assignment is not definable
+! CHECK: because: 'c' has the PROTECTED_TARGET attribute
+! CHECK: error: Object in DEALLOCATE statement is not deallocatable
+! CHECK: because: 'mp' has the PROTECTED_TARGET attribute
+! CHECK: error: The target of PROTECTED_TARGET pointer 'q' may not be associated with POINTER dummy argument 'd=', which does not have the PROTECTED_TARGET attribute
diff --git a/flang/test/Semantics/protected-target-mod.f90 b/flang/test/Semantics/protected-target-mod.f90
new file mode 100644
index 0000000000000..172a458d0ae04
--- /dev/null
+++ b/flang/test/Semantics/protected-target-mod.f90
@@ -0,0 +1,33 @@
+! RUN: %python %S/test_modfile.py %s %flang_fc1
+! The PROTECTED_TARGET attribute in module files
+
+module m
+ integer, target :: x
+ integer, pointer, protected_target :: p1 => x
+ real, pointer :: p2(:)
+ protected_target :: p2
+ type :: t
+ integer, pointer, protected_target :: c
+ end type
+ contains
+ function f(d) result(r)
+ integer, pointer, protected_target, intent(in) :: d
+ integer, pointer, protected_target :: r
+ r => d
+ end
+end
+
+!Expect: m.mod
+!module m
+!integer(4),target::x
+!integer(4),pointer,protected_target::p1
+!real(4),pointer,protected_target::p2(:)
+!type::t
+!integer(4),pointer,protected_target::c
+!end type
+!contains
+!function f(d) result(r)
+!integer(4),intent(in),pointer,protected_target::d
+!integer(4),pointer,protected_target::r
+!end
+!end
diff --git a/flang/test/Semantics/protected-target-pointer.f90 b/flang/test/Semantics/protected-target-pointer.f90
new file mode 100644
index 0000000000000..432abd0d75ff2
--- /dev/null
+++ b/flang/test/Semantics/protected-target-pointer.f90
@@ -0,0 +1,184 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+! The target of a PROTECTED_TARGET pointer may become associated only with
+! another PROTECTED_TARGET pointer (F'2028 C870, C871).
+
+module m
+ integer, target, protected :: px = 1
+ integer, pointer, protected_target :: mp
+ type :: t
+ integer, pointer :: c
+ end type
+ type :: pt_t
+ integer, pointer, protected_target :: c
+ end type
+ type :: node
+ integer :: n
+ integer, pointer :: next
+ contains
+ procedure :: getn
+ end type
+ contains
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => px
+ end
+ function getn(this) result(r)
+ class(node), intent(in) :: this
+ integer, pointer, protected_target :: r
+ r => this%next
+ end
+ function getw() result(r)
+ integer, pointer :: r
+ r => px
+ end
+end
+
+subroutine assignments(p, pa, pn, x)
+ use m
+ integer, pointer, protected_target :: p, pa(:), q, qa(:)
+ type(node), pointer, protected_target :: pn
+ integer, target :: x
+ integer, pointer :: w, wa(:)
+ type(t) :: a
+ type(pt_t) :: b
+ procedure(get), pointer :: fp
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w => p
+ !ERROR: The target of PROTECTED_TARGET pointer 'pa' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w => pa(1)
+ !ERROR: The target of PROTECTED_TARGET pointer 'pa' may not be associated with pointer 'wa', which does not have the PROTECTED_TARGET attribute
+ wa => pa(1:2)
+ !ERROR: The target of PROTECTED_TARGET pointer 'pa' may not be associated with pointer 'wa', which does not have the PROTECTED_TARGET attribute
+ wa(1:2) => pa
+ !ERROR: The target of PROTECTED_TARGET pointer 'pn' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w => pn%n
+ !ERROR: The target of PROTECTED_TARGET pointer 'r' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w => get()
+ !ERROR: The target of PROTECTED_TARGET pointer 'r' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w => pn%getn()
+ fp => get
+ !ERROR: The target of PROTECTED_TARGET pointer 'r' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w => fp()
+ !ERROR: The target of PROTECTED_TARGET pointer 'c' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w => b%c
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with pointer 'c', which does not have the PROTECTED_TARGET attribute
+ a%c => p
+ ! Accepted: an ASSOCIATE name does not have the PROTECTED_TARGET attribute
+ ! (F'2028 11.1.3.3p1), so only the optional warning applies.
+ associate (s => pa)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'pa' has the PROTECTED_TARGET attribute
+ w => s(1)
+ end associate
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' may not be associated with pointer 'c', which does not have the PROTECTED_TARGET attribute
+ a = t(p)
+ !ERROR: The target of PROTECTED_TARGET pointer 'pa' may not be associated with pointer 'c', which does not have the PROTECTED_TARGET attribute
+ a = t(c=pa(2))
+ ! A pointer component of the target is a subobject of the target as a
+ ! data-target, but its own target is not.
+ !ERROR: Pointer component 'next' of the target of PROTECTED_TARGET pointer 'pn' may not be a data-target for pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w => pn%next
+ !ERROR: Pointer component 'next' of the target of PROTECTED_TARGET pointer 'pn' may not be a data-target for pointer 'c', which does not have the PROTECTED_TARGET attribute
+ a%c => pn%next
+ !ERROR: Pointer component 'next' of the target of PROTECTED_TARGET pointer 'pn' may not be a data-target for pointer 'c', which does not have the PROTECTED_TARGET attribute
+ a = t(pn%next)
+ associate (s => pn%next)
+ w => s
+ end associate
+ ! Valid: protection is kept, or an ordinary pointer gains it.
+ q => p
+ q => pa(1)
+ qa => pa(1:2)
+ q => pn%n
+ q => pn%next
+ q => get()
+ q => pn%getn()
+ q => fp()
+ q => getw()
+ q => b%c
+ q => w
+ b%c => p
+ b%c => pn%next
+ b = pt_t(p)
+ b = pt_t(c=pa(1))
+ b = pt_t(pn%next)
+ a = t(w)
+ w => x
+ q => x
+ print *, q, qa, a%c, b%c
+end
+
+subroutine select_rank(ar, qa)
+ use m
+ integer, pointer, protected_target :: ar(..), qa(:)
+ integer, pointer :: w(:)
+ type(t) :: a
+ ! A RANK(n) associate name is a pointer without the PROTECTED_TARGET
+ ! attribute (F'2028 11.1.12.3p3). Accepted as a data-target: only the
+ ! optional warning applies.
+ select rank (r => ar)
+ rank (0)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ a = t(r)
+ rank (1)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ w => r
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'ar' has the PROTECTED_TARGET attribute
+ w => r(1:1)
+ !ERROR: The target of PROTECTED_TARGET pointer 'qa' may not be associated with pointer 'r', which does not have the PROTECTED_TARGET attribute
+ r => qa
+ qa => r
+ rank default
+ ! A RANK DEFAULT associate name has exactly the attributes of its
+ ! selector (F'2028 11.1.12.3p2).
+ !ERROR: The target of PROTECTED_TARGET pointer 'ar' may not be associated with pointer 'w', which does not have the PROTECTED_TARGET attribute
+ w(1:1) => r
+ qa(1:1) => r
+ end select
+end
+
+subroutine targets(x)
+ use m
+ integer, target, intent(in) :: x
+ integer, pointer :: w
+ integer, pointer, protected_target :: q
+ ! F'2028 C864 forbids a use-associated nonpointer PROTECTED object as a
+ ! data-target, although the non-normative 8.5.16 NOTE 1 shows the
+ ! equivalent of "mp => px" as valid. For every pointer, Flang reports C864
+ ! only as an optional warning. An INTENT(IN) target violates no
+ ! constraint, and a PROTECTED_TARGET pointer cannot define it, so it gets
+ ! no warning.
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'px' is protected in this scope
+ q => px
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'px' is protected in this scope
+ mp => px
+ q => x
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'px' is protected in this scope
+ w => px
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is an INTENT(IN) dummy argument
+ w => x
+ print *, q, w
+end
+
+module m2
+ use m
+ ! Pointer initialization is treated like the pointer assignments above:
+ ! C864 also forbids px as an initial-data-target.
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'px' is protected in this scope
+ integer, pointer, protected_target :: init => px
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'px' is protected in this scope
+ integer, pointer :: winit => px
+ type(node), pointer, protected_target :: mpn
+ ! An initial data target may not involve a pointer, so C870 is not reached.
+ !ERROR: An initial data target may not be a reference to a POINTER 'next'
+ integer, pointer :: wnext => mpn%next
+end
More information about the flang-commits
mailing list