[flang-commits] [flang] [flang] Add the Fortran 2028 PROTECTED_TARGET attribute (PR #231738)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Tue Oct 13 20:47:46 PDT 2026
https://github.com/Saieiei created https://github.com/llvm/llvm-project/pull/231738
Fortran 2028 (working draft J3/26-007r1, WG5 item US15) adds the
PROTECTED_TARGET attribute for data pointers: the target of such a pointer
cannot be defined through it. Flang rejected it in the parser.
Parse and unparse the attribute, the component attribute and the statement,
carry it through module files, reject the attribute on anything other than a
data pointer (8.5.16p1), and check C781, C866-C874 and C8109 as errors,
including definitions through subobjects and associate names.
As in the existing definability checks, the nearest pointer in a designator
decides whether a target is protected (9.4.2p5). A pointer component X%P,
where X has PROTECTED_TARGET, is still part of X's target when X%P is passed
to a pointer dummy, so that dummy needs PROTECTED_TARGET (9.4.2 NOTE 1).
Where C864 and 8.5.16 NOTE 1 conflict, this follows NOTE 1: a
PROTECTED_TARGET pointer may point to a use-associated PROTECTED object.
The attribute is not a procedure characteristic (15.3.2.2, 15.3.3), so a
mismatch between an interface and its procedure is not diagnosed. Only a
RANK DEFAULT associate name gets it, so C870-C874 do not apply to other
associate names. A function reference with a PROTECTED_TARGET result counts
as that pointer. C872 skips intrinsic pointer arguments, which only inquire
or set association, and C867 skips a pointer component of a sequence object
in COMMON. OpenMP LASTPRIVATE accepts a PROTECTED_TARGET pointer; REDUCTION
still rejects it. NOTE 2 is not diagnosed and, as for SIMPLE, there is no
-std or -pedantic diagnostic.
Assisted-by: GitHub Copilot
>From 4b459d3530261984f284523bacf745224acfcde9 Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Tue, 13 Oct 2026 22:47:30 -0500
Subject: [PATCH] [flang] Add the Fortran 2028 PROTECTED_TARGET attribute
Fortran 2028 (working draft J3/26-007r1, WG5 item US15) adds the
PROTECTED_TARGET attribute for data pointers: the target of such a pointer
cannot be defined through it. Flang rejected it in the parser.
Parse and unparse the attribute, the component attribute and the statement,
carry it through module files, reject the attribute on anything other than a
data pointer (8.5.16p1), and check C781, C866-C874 and C8109 as errors,
including definitions through subobjects and associate names.
As in the existing definability checks, the nearest pointer in a designator
decides whether a target is protected (9.4.2p5). A pointer component X%P,
where X has PROTECTED_TARGET, is still part of X's target when X%P is passed
to a pointer dummy, so that dummy needs PROTECTED_TARGET (9.4.2 NOTE 1).
Where C864 and 8.5.16 NOTE 1 conflict, this follows NOTE 1: a
PROTECTED_TARGET pointer may point to a use-associated PROTECTED object.
The attribute is not a procedure characteristic (15.3.2.2, 15.3.3), so a
mismatch between an interface and its procedure is not diagnosed. Only a
RANK DEFAULT associate name gets it, so C870-C874 do not apply to other
associate names. A function reference with a PROTECTED_TARGET result counts
as that pointer. C872 skips intrinsic pointer arguments, which only inquire
or set association, and C867 skips a pointer component of a sequence object
in COMMON. OpenMP LASTPRIVATE accepts a PROTECTED_TARGET pointer; REDUCTION
still rejects it. NOTE 2 is not diagnosed and, as for SIMPLE, there is no
-std or -pedantic diagnostic.
Assisted-by: GitHub Copilot
---
flang/docs/FortranStandardsSupport.md | 7 +
flang/examples/FeatureList/FeatureList.cpp | 2 +
.../include/flang/Evaluate/characteristics.h | 17 +-
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 24 +-
flang/include/flang/Semantics/attr.h | 4 +-
flang/include/flang/Semantics/tools.h | 7 +
flang/lib/Evaluate/characteristics.cpp | 22 +-
flang/lib/Parser/Fortran-parsers.cpp | 8 +-
flang/lib/Parser/misc-parsers.h | 2 +
flang/lib/Parser/program-parsers.cpp | 1 +
flang/lib/Parser/unparse.cpp | 4 +
flang/lib/Semantics/check-allocate.cpp | 7 +
flang/lib/Semantics/check-call.cpp | 30 +-
flang/lib/Semantics/check-coarray.cpp | 28 +-
flang/lib/Semantics/check-deallocate.cpp | 7 +
flang/lib/Semantics/check-declarations.cpp | 30 +-
flang/lib/Semantics/check-io.cpp | 7 +
flang/lib/Semantics/check-omp-structure.cpp | 6 +
flang/lib/Semantics/definable.cpp | 29 +-
flang/lib/Semantics/pointer-assignment.cpp | 72 +-
flang/lib/Semantics/pointer-assignment.h | 3 +-
flang/lib/Semantics/resolve-names.cpp | 10 +-
flang/lib/Semantics/tools.cpp | 51 ++
.../Parser/unparse-protected-target-fixed.f | 17 +
.../test/Parser/unparse-protected-target.f90 | 27 +
.../OpenMP/lastprivate-protected-target.f90 | 57 ++
.../modfile-protected-target-read.f90 | 59 ++
.../Semantics/modfile-protected-target.f90 | 31 +
flang/test/Semantics/protected_target01.f90 | 616 ++++++++++++++++++
flang/test/Semantics/protected_target02.f90 | 176 +++++
31 files changed, 1325 insertions(+), 38 deletions(-)
create mode 100644 flang/test/Parser/unparse-protected-target-fixed.f
create mode 100644 flang/test/Parser/unparse-protected-target.f90
create mode 100644 flang/test/Semantics/OpenMP/lastprivate-protected-target.f90
create mode 100644 flang/test/Semantics/modfile-protected-target-read.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
diff --git a/flang/docs/FortranStandardsSupport.md b/flang/docs/FortranStandardsSupport.md
index dd8bda23cb495..0a4d251c40f9e 100644
--- a/flang/docs/FortranStandardsSupport.md
+++ b/flang/docs/FortranStandardsSupport.md
@@ -23,6 +23,13 @@ There is no distinction made between support in the Parser/Semantics and the MLI
Note: The two major missing features in Flang at present are coarrays and parameterized derived types (PDTs) with length type parameters.
+## Fortran 2028 (working draft J3/26-007r1)
+
+| Feature | Status | Comments |
+|------------------------------------------------------------|--------|-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|
+| PROTECTED_TARGET attribute and statement (US15) | Y | Follows 8.5.16 NOTE 1 where it conflicts with C864; not a procedure characteristic; C872 is not applied to pointer arguments of intrinsic procedures |
+
+
## Fortran 2023
See [document](F202X.md) for a brief discussion about the new features in Fortran 2023. The following table summarizes the
status of all important Fortran 2023 features. The table entries are based on the document [The new features in Fortran 2023](https://wg5-fortran.org/N2201-N2250/N2212.pdf).
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..1425642a3cf5c 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -233,11 +233,16 @@ class TypeAndShape {
// 15.3.2.2
struct DummyDataObject {
+ // PROTECTED_TARGET is carried here for constraint checks at references
+ // (e.g. F'2028 C872) and is not compared because F'2028 15.3.2.2 does not
+ // list it.
ENUM_CLASS(Attr, Optional, Allocatable, Asynchronous, Contiguous, Value,
- Volatile, Pointer, Target, DeducedFromActual, OnlyIntrinsicInquiry)
+ Volatile, Pointer, Target, DeducedFromActual, OnlyIntrinsicInquiry,
+ ProtectedTarget)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
static bool IdenticalSignificantAttrs(const Attrs &x, const Attrs &y) {
- return (x - Attr::DeducedFromActual) == (y - Attr::DeducedFromActual);
+ return (x - Attr::DeducedFromActual - Attr::ProtectedTarget) ==
+ (y - Attr::DeducedFromActual - Attr::ProtectedTarget);
}
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyDataObject)
explicit DummyDataObject(const TypeAndShape &t) : type{t} {}
@@ -327,8 +332,14 @@ using DummyArguments = std::vector<DummyArgument>;
// 15.3.3
struct FunctionResult {
- ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous)
+ // PROTECTED_TARGET is recorded so that the characteristics describe the
+ // result completely; it is not compared because F'2028 15.3.3 does not
+ // list it.
+ ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous, ProtectedTarget)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
+ static bool IdenticalSignificantAttrs(const Attrs &x, const Attrs &y) {
+ return (x - Attr::ProtectedTarget) == (y - Attr::ProtectedTarget);
+ }
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
explicit FunctionResult(DynamicType);
explicit FunctionResult(TypeAndShape &&);
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..738bf31ae09de 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; // F'2028 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 {
@@ -390,7 +392,8 @@ struct OtherSpecificationStmt {
common::Indirection<ValueStmt>, common::Indirection<VolatileStmt>,
common::Indirection<CommonStmt>, common::Indirection<EquivalenceStmt>,
common::Indirection<BasedPointerStmt>,
- common::Indirection<CUDAAttributesStmt>>
+ common::Indirection<CUDAAttributesStmt>,
+ common::Indirection<ProtectedTargetStmt>>
u;
};
@@ -995,9 +998,11 @@ struct ComponentArraySpec {
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// 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;
};
@@ -1405,7 +1411,8 @@ WRAPPER_CLASS(RankClause, ScalarIntConstantExpr);
// 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 |
+// PROTECTED | PROTECTED_TARGET | RANK ( scalar-int-constant-expr ) |
+// SAVE | TARGET |
// VALUE | VOLATILE |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE
EMPTY_CLASS(Asynchronous);
@@ -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;
};
@@ -1613,6 +1620,9 @@ struct PointerDecl {
// R853 pointer-stmt -> POINTER [::] pointer-decl-list
WRAPPER_CLASS(PointerStmt, std::list<PointerDecl>);
+// F'2028 R863 protected-target-stmt -> PROTECTED_TARGET [::] variable-name-list
+WRAPPER_CLASS(ProtectedTargetStmt, std::list<Name>);
+
// R855 protected-stmt -> PROTECTED [::] entity-name-list
WRAPPER_CLASS(ProtectedStmt, std::list<Name>);
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..6ad45d4c0eca9 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -178,6 +178,13 @@ 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);
+}
+const Symbol *FindProtectedTargetPointer(
+ const evaluate::DataRef &, bool isPointerDefinition = false);
+const Symbol *FindProtectedTargetPointer(
+ const SomeExpr &, bool isPointerDefinition = false);
inline bool IsImpliedDoIndex(const Symbol &symbol) {
return symbol.owner().kind() == Scope::Kind::ImpliedDos;
}
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 4b05a25fd8f58..cf4dc39db9be2 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -281,8 +281,10 @@ llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
}
bool DummyDataObject::operator==(const DummyDataObject &that) const {
- return type == that.type && attrs == that.attrs && intent == that.intent &&
- coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
+ return type == that.type &&
+ (attrs - Attr::ProtectedTarget) == (that.attrs - Attr::ProtectedTarget) &&
+ intent == that.intent && coshape == that.coshape &&
+ cudaDataAttr == that.cudaDataAttr;
}
static bool IsOkWithSequenceAssociation(
@@ -372,7 +374,7 @@ bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
if (!IdenticalSignificantAttrs(attrs, actual.attrs)) {
if (whyNot) {
*whyNot = "incompatible dummy data object attributes";
- auto differences{attrs ^ actual.attrs};
+ auto differences{(attrs ^ actual.attrs) - Attr::ProtectedTarget};
auto sep{": "s};
differences.IterateOverMembers([&](DummyDataObject::Attr x) {
*whyNot += sep + std::string{EnumToString(x)};
@@ -440,6 +442,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
{Attr::VOLATILE, DummyDataObject::Attr::Volatile},
{Attr::POINTER, DummyDataObject::Attr::Pointer},
{Attr::TARGET, DummyDataObject::Attr::Target},
+ {Attr::PROTECTED_TARGET, DummyDataObject::Attr::ProtectedTarget},
});
result->intent = GetIntent(symbol.attrs());
result->ignoreTKR = GetIgnoreTKR(symbol);
@@ -1059,8 +1062,8 @@ FunctionResult::FunctionResult(Procedure &&p) : u{std::move(p)} {}
FunctionResult::~FunctionResult() {}
bool FunctionResult::operator==(const FunctionResult &that) const {
- return attrs == that.attrs && cudaDataAttr == that.cudaDataAttr &&
- u == that.u;
+ return IdenticalSignificantAttrs(attrs, that.attrs) &&
+ cudaDataAttr == that.cudaDataAttr && u == that.u;
}
static std::optional<FunctionResult> CharacterizeFunctionResult(
@@ -1075,6 +1078,8 @@ static std::optional<FunctionResult> CharacterizeFunctionResult(
{semantics::Attr::ALLOCATABLE, FunctionResult::Attr::Allocatable},
{semantics::Attr::CONTIGUOUS, FunctionResult::Attr::Contiguous},
{semantics::Attr::POINTER, FunctionResult::Attr::Pointer},
+ {semantics::Attr::PROTECTED_TARGET,
+ FunctionResult::Attr::ProtectedTarget},
});
result.cudaDataAttr = object->cudaDataAttr();
return result;
@@ -1195,11 +1200,12 @@ static std::optional<std::string> AreIncompatibleFunctionResultShapes(
bool FunctionResult::IsCompatibleWith(
const FunctionResult &actual, std::string *whyNot) const {
- Attrs actualAttrs{actual.attrs};
- if (!attrs.test(Attr::Contiguous)) {
+ Attrs actualAttrs{actual.attrs - Attr::ProtectedTarget};
+ Attrs myAttrs{attrs - Attr::ProtectedTarget};
+ if (!myAttrs.test(Attr::Contiguous)) {
actualAttrs.reset(Attr::Contiguous);
}
- if (attrs != actualAttrs) {
+ if (myAttrs != actualAttrs) {
if (whyNot) {
*whyNot = "function results have incompatible attributes";
}
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 263ce9249a8b2..f537c43db24b4 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -476,6 +476,7 @@ TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(contiguous) ||
construct<ComponentAttrSpec>("DIMENSION" >> componentArraySpec) ||
construct<ComponentAttrSpec>(pointer) ||
+ construct<ComponentAttrSpec>(protectedTargetAttr) ||
extension<LanguageFeature::CUDA>(
construct<ComponentAttrSpec>(Parser<CUDADataAttrSpec>{})) ||
construct<ComponentAttrSpec>(recovery(
@@ -756,7 +757,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) ||
@@ -1046,6 +1048,10 @@ TYPE_PARSER(construct<PointerStmt>("POINTER" >> maybe("::"_tok) >>
TYPE_PARSER(
construct<PointerDecl>(name, maybe(parenthesized(deferredShapeSpecList))))
+// F'2028 R863 protected-target-stmt -> PROTECTED_TARGET [::] variable-name-list
+TYPE_PARSER(construct<ProtectedTargetStmt>(
+ "PROTECTED_TARGET" >> maybe("::"_tok) >> listOfNames))
+
// R855 protected-stmt -> PROTECTED [::] entity-name-list
TYPE_PARSER(
construct<ProtectedStmt>("PROTECTED" >> maybe("::"_tok) >> listOfNames))
diff --git a/flang/lib/Parser/misc-parsers.h b/flang/lib/Parser/misc-parsers.h
index 4a318e05bb4b8..c191b5ba36a78 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 protectedTargetAttr{
+ 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..933214037ed2d 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -232,6 +232,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..e846af593fac9 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) { // 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..ee9ff7bfaaba1 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -700,6 +700,13 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
return false;
}
}
+ if (ultimate_ && IsProtectedTarget(*ultimate_)) {
+ if (!allocateInfo_.gotSource) { // F'2028 C869
+ context.Say(name_.source,
+ "An ALLOCATE statement for a pointer with the PROTECTED_TARGET attribute must have a SOURCE= clause"_err_en_US);
+ return false;
+ }
+ }
if (allocateInfo_.gotPinned) {
std::optional<common::CUDADataAttr> cudaAttr{GetCUDADataAttr(ultimate_)};
if ((!cudaAttr || *cudaAttr != common::CUDADataAttr::Pinned) &&
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index feabf0cd33bf0..043b5b50bcb0c 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -67,6 +67,11 @@ void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
"%VAL argument must be a scalar numeric or logical expression"_err_en_US);
}
if (const auto *expr{arg.UnwrapExpr()}) {
+ if (FindProtectedTargetPointer(*expr)) { // F'2028 C873
+ messages.Say(
+ "A pointer with the PROTECTED_TARGET attribute (or a subobject thereof) may not be passed to a procedure with an implicit interface"_err_en_US);
+ return;
+ }
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
@@ -1041,9 +1046,25 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (dummyIsPointer) {
if (actualIsPointer || dummy.intent == common::Intent::In) {
if (scope) {
+ // C872 is not applied to intrinsic procedures: intrinsic pointer dummy
+ // arguments (e.g. FPTR of C_F_POINTER) only inquire or set association
+ // and never define the target through the pointer.
semantics::CheckPointerAssignment(context, messages.at(), dummyName,
dummy, actual, *scope,
- /*isAssumedRank=*/dummyIsAssumedRank, actualIsPointer);
+ /*isAssumedRank=*/dummyIsAssumedRank, actualIsPointer,
+ /*isIntrinsic=*/intrinsic != nullptr);
+ // F'2028 C872: catches X%P, where X is a PROTECTED_TARGET pointer
+ // and P an ordinary pointer component, passed to a pointer dummy;
+ // there X%P is part of X's target.
+ if (!dummy.attrs.test(
+ characteristics::DummyDataObject::Attr::ProtectedTarget) &&
+ !intrinsic && actualIsPointer &&
+ !FindProtectedTargetPointer(actual) &&
+ FindProtectedTargetPointer(actual, /*isPointerDefinition=*/true)) {
+ messages.Say(
+ "%s must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof"_err_en_US,
+ dummyName);
+ }
}
} else if (!actualIsPointer &&
!dummy.ignoreTKR.test(common::IgnoreTKR::Pointer)) {
@@ -1051,6 +1072,13 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
"Actual argument associated with POINTER %s must also be POINTER unless INTENT(IN)"_err_en_US,
dummyName);
}
+ } else if (scope && dummy.intent == common::Intent::Default &&
+ !intrinsic) { // F'2028 C874
+ if (FindProtectedTargetPointer(actual)) {
+ messages.Say(
+ "Actual argument associated with %s is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument"_err_en_US,
+ dummyName);
+ }
}
// 15.5.2.5 -- actual & dummy are both POINTER or both ALLOCATABLE
diff --git a/flang/lib/Semantics/check-coarray.cpp b/flang/lib/Semantics/check-coarray.cpp
index 00b97162ff0d4..6b32ddcf68bd4 100644
--- a/flang/lib/Semantics/check-coarray.cpp
+++ b/flang/lib/Semantics/check-coarray.cpp
@@ -356,13 +356,24 @@ void CoarrayChecker::Leave(const parser::LockStmt &x) {
std::get_if<parser::StatOrErrmsg>(&lockStat.u)}) {
CheckSyncStat(context_, *statOrErrmsg, gotStat, gotMsg);
} else {
- CHECK(std::holds_alternative<
- parser::Scalar<parser::Logical<parser::Variable>>>(lockStat.u));
+ const auto &var{
+ std::get<parser::Scalar<parser::Logical<parser::Variable>>>(
+ lockStat.u)};
if (gotAcquired) {
context_.Say(parser::FindSourceLocation(lockStat),
"Multiple ACQUIRED_LOCK specifiers"_err_en_US);
} else {
gotAcquired = true;
+ if (const auto *expr{GetExpr(context_, var)}) {
+ if (const Symbol *ptSym{FindProtectedTargetPointer(*expr)}) {
+ auto at{parser::FindSourceLocation(var)};
+ context_
+ .Say(at, "ACQUIRED_LOCK= variable is not definable"_err_en_US)
+ .Attach(at,
+ "The target of '%s' with the PROTECTED_TARGET attribute may not be defined"_because_en_US,
+ ptSym->name());
+ }
+ }
}
}
}
@@ -388,8 +399,17 @@ void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
}
void CoarrayChecker::Leave(const parser::FormTeamStmt &x) {
- CheckTeamType(
- context_, std::get<parser::TeamVariable>(x.t), /*mustBeVariable=*/true);
+ const auto &teamVar{std::get<parser::TeamVariable>(x.t)};
+ CheckTeamType(context_, teamVar, /*mustBeVariable=*/true);
+ if (const auto *expr{GetExpr(context_, teamVar)}) {
+ if (const Symbol *ptSym{FindProtectedTargetPointer(*expr)}) {
+ auto at{parser::FindSourceLocation(teamVar)};
+ context_.Say(at, "Team-variable is not definable"_err_en_US)
+ .Attach(at,
+ "The target of '%s' with the PROTECTED_TARGET attribute may not be defined"_because_en_US,
+ ptSym->name());
+ }
+ }
for (const auto &spec :
std::get<std::list<parser::FormTeamStmt::FormTeamSpec>>(x.t)) {
if (const auto *statOrErrmsg{std::get_if<parser::StatOrErrmsg>(&spec.u)}) {
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index c93b940aa69ed..354d8af4bbcc5 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -68,6 +68,9 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
} else if (!IsAllocatableOrObjectPointer(symbol)) { // C936
context_.Say(source,
"Name in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+ } else if (IsProtectedTarget(*symbol)) { // F'2028 C868
+ context_.Say(source,
+ "A pointer with the PROTECTED_TARGET attribute may not be an allocate-object in a DEALLOCATE statement"_err_en_US);
} else if (auto whyNot{
WhyNotDefinable(source, context_.FindScope(source),
{DefinabilityFlag::PointerDefinition,
@@ -108,6 +111,10 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
!IsAllocatableOrObjectPointer(symbol)) { // F'2023 C936
context_.Say(source,
"Component in DEALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
+ } else if (symbol &&
+ IsProtectedTarget(*symbol)) { // F'2028 C868
+ context_.Say(source,
+ "A pointer with the PROTECTED_TARGET attribute may not be an allocate-object in a DEALLOCATE statement"_err_en_US);
} else if (auto whyNot{WhyNotDefinable(source,
context_.FindScope(source),
{DefinabilityFlag::PointerDefinition,
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 2abefd381850a..4395a59d971ef 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -66,6 +66,7 @@ class CheckHelper {
void CheckVolatile(const Symbol &, const DerivedTypeSpec *);
void CheckContiguous(const Symbol &);
void CheckPointer(const Symbol &);
+ void CheckProtectedTarget(const Symbol &);
void CheckPassArg(
const Symbol &proc, const Symbol *interface, const WithPassArg &);
void CheckProcBinding(const Symbol &, const ProcBindingDetails &);
@@ -347,6 +348,9 @@ void CheckHelper::Check(const Symbol &symbol) {
"A PROTECTED entity may not be in a common block"_err_en_US);
}
}
+ if (IsProtectedTarget(symbol)) {
+ CheckProtectedTarget(symbol);
+ }
if (IsPointer(symbol)) {
CheckPointer(symbol);
}
@@ -2610,6 +2614,28 @@ void CheckHelper::CheckPointer(const Symbol &symbol) { // C852
}
}
+void CheckHelper::CheckProtectedTarget(const Symbol &symbol) {
+ if (symbol.owner().IsDerivedType()) {
+ if (!symbol.attrs().test(Attr::POINTER)) { // F'2028 C781
+ messages_.Say(
+ "PROTECTED_TARGET component '%s' must have the POINTER attribute"_err_en_US,
+ symbol.name());
+ }
+ } else {
+ // F'2028 8.5.16p1 (and F'2028 C8109 for the statement)
+ if (!IsPointer(symbol) || IsProcedure(symbol)) {
+ messages_.Say(
+ "PROTECTED_TARGET entity '%s' must be a data pointer"_err_en_US,
+ symbol.name());
+ }
+ }
+ if (FindCommonBlockContaining(symbol)) { // F'2028 C867
+ messages_.Say(
+ "A pointer '%s' with the PROTECTED_TARGET attribute may not be in a COMMON block"_err_en_US,
+ symbol.name());
+ }
+}
+
// C760 constraints on the passed-object dummy argument
// C757 constraints on procedure pointer components
void CheckHelper::CheckPassArg(
@@ -4177,7 +4203,9 @@ void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
const Symbol &symbol2, const DummyDataObject &obj1,
const DummyDataObject &obj2) {
if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
- } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
+ } else if (!CheckSameAttrs(symbol1, symbol2,
+ obj1.attrs - DummyDataObject::Attr::ProtectedTarget,
+ obj2.attrs - DummyDataObject::Attr::ProtectedTarget)) {
} else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
Say(symbol1, symbol2,
"Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index bc9181592aeb5..5519020df13e1 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -811,6 +811,13 @@ void IoChecker::Leave(const parser::InquireStmt &stmt) {
CheckForProhibitedSpecifier(IoSpecKind::File, IoSpecKind::Unit); // C1246
CheckForRequiredSpecifier(IoSpecKind::Id, IoSpecKind::Pending); // C1248
CheckForUselessIomsg();
+ } else if (const auto *iolength{
+ std::get_if<parser::InquireStmt::Iolength>(&stmt.u)}) {
+ const auto &var{std::get<parser::ScalarIntVariable>(iolength->t)};
+ if (const auto *expr{GetExpr(context_, var)};
+ expr && FindProtectedTargetPointer(*expr)) { // F'2028 C866
+ CheckForDefinableVariable(var, "IOLENGTH");
+ }
}
Done();
}
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 6193b297b62fb..5ad1c87a501c6 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -6184,6 +6184,12 @@ void OmpStructureChecker::CheckDefinableObjects(
if (!IsVariableListItem(*symbol)) {
continue;
}
+ // A POINTER list item of LASTPRIVATE is updated as if by pointer
+ // assignment (OpenMP 5.2, 5.4.5), so its target is not defined.
+ if (clause == llvm::omp::Clause::OMPC_lastprivate && IsPointer(*symbol) &&
+ IsProtectedTarget(symbol->GetUltimate())) {
+ 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..87e5121a2c652 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -23,6 +23,13 @@ static parser::Message BlameSymbol(parser::CharBlock at,
return message;
}
+static parser::Message BlameProtectedTarget(
+ parser::CharBlock at, const Symbol &symbol) {
+ return BlameSymbol(at,
+ "The target of '%s' with the PROTECTED_TARGET attribute may not be defined"_en_US,
+ symbol);
+}
+
static bool IsPointerDummyOfPureFunction(const Symbol &x) {
return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) &&
x.owner().symbol() && IsFunction(*x.owner().symbol());
@@ -109,8 +116,14 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
} else if (evaluate::HasVectorSubscript(association->expr().value())) {
return BlameSymbol(at,
"Construct association '%s' has a vector subscript"_en_US, original);
- } else if (auto dataRef{evaluate::ExtractDataRef(
- *association->expr(), true, true)}) {
+ } else if (!isComponentPointerTarget) {
+ if (const Symbol *ptSym{FindProtectedTargetPointer(
+ *association->expr(), /*isPointerDefinition=*/false)}) {
+ return BlameProtectedTarget(at, *ptSym);
+ }
+ }
+ if (auto dataRef{
+ evaluate::ExtractDataRef(*association->expr(), true, true)}) {
return WhyNotDefinableBase(at, scope, flags, dataRef->GetFirstSymbol(),
isWholeSymbol &&
std::holds_alternative<evaluate::SymbolRef>(dataRef->u),
@@ -253,6 +266,10 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags,
const evaluate::DataRef &dataRef) {
+ if (const Symbol *ptSym{FindProtectedTargetPointer(
+ dataRef, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameProtectedTarget(at, *ptSym);
+ }
auto whyNotBase{
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
@@ -270,6 +287,11 @@ static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
+ if (const Symbol *ptSym{
+ FindProtectedTargetPointer(evaluate::DataRef{original},
+ flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameProtectedTarget(at, *ptSym);
+ }
auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
/*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
if (!whyNotBase || !whyNotBase->IsFatal()) {
@@ -397,6 +419,9 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
if (auto whyNotDataRef{WhyNotDefinable(at, scope, flags, *dataRef)}) {
return whyNotDataRef;
}
+ } else if (const Symbol *ptSym{FindProtectedTargetPointer(
+ expr, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameProtectedTarget(at, *ptSym);
} else if (evaluate::IsNullPointerOrAllocatable(&expr)) {
return parser::Message{
at, "'%s' is a null pointer"_err_en_US, expr.AsFortran()};
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..d8c35849768fa 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -50,6 +50,7 @@ class PointerAssignmentChecker {
set_lhsType(TypeAndShape::Characterize(lhs, foldingContext_));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
+ set_isProtectedTarget(IsProtectedTarget(lhs.GetUltimate()));
}
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_isContiguous(bool);
@@ -59,6 +60,9 @@ class PointerAssignmentChecker {
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
PointerAssignmentChecker &set_isRHSPointerActualArgument(bool);
PointerAssignmentChecker &set_ignoreTKR(common::IgnoreTKRSet);
+ PointerAssignmentChecker &set_isProtectedTarget(bool);
+ PointerAssignmentChecker &set_isDummyArgument(bool);
+ PointerAssignmentChecker &set_isIntrinsic(bool);
bool CheckLeftHandSide(const SomeExpr &);
bool Check(const SomeExpr &);
@@ -97,6 +101,9 @@ class PointerAssignmentChecker {
bool isRHSPointerActualArgument_{false};
common::IgnoreTKRSet ignoreTKR_;
const Symbol *pointerComponentLHS_{nullptr};
+ bool isProtectedTarget_{false};
+ bool isDummyArgument_{false};
+ bool isIntrinsic_{false};
};
PointerAssignmentChecker &PointerAssignmentChecker::set_lhsType(
@@ -135,6 +142,24 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_pointerComponentLHS(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isProtectedTarget(
+ bool isProtectedTarget) {
+ isProtectedTarget_ = isProtectedTarget;
+ return *this;
+}
+
+PointerAssignmentChecker &PointerAssignmentChecker::set_isDummyArgument(
+ bool isDummyArgument) {
+ isDummyArgument_ = isDummyArgument;
+ return *this;
+}
+
+PointerAssignmentChecker &PointerAssignmentChecker::set_isIntrinsic(
+ bool isIntrinsic) {
+ isIntrinsic_ = isIntrinsic;
+ return *this;
+}
+
PointerAssignmentChecker &
PointerAssignmentChecker::set_isRHSPointerActualArgument(bool isPointerActual) {
isRHSPointerActualArgument_ = isPointerActual;
@@ -243,13 +268,42 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
"Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
}
}
+ // F'2028 C870, C871, C872: If target is a pointer with the PROTECTED_TARGET
+ // attribute or a subobject thereof, the receiving pointer must also have
+ // the PROTECTED_TARGET attribute.
+ if (FindProtectedTargetPointer(rhs)) {
+ if (!isProtectedTarget_) {
+ if (pointerComponentLHS_) { // F'2028 C871
+ Say("A structure constructor component must have the PROTECTED_TARGET attribute when the value is a pointer with the PROTECTED_TARGET attribute or a subobject thereof"_err_en_US);
+ return false;
+ } else if (isDummyArgument_) { // F'2028 C872
+ if (!isIntrinsic_) {
+ Say("%s must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof"_err_en_US,
+ description_);
+ return false;
+ }
+ } else { // F'2028 C870
+ Say("Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof"_err_en_US);
+ return false;
+ }
+ }
+ }
// 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;
+ // F'2028 C864 forbids a use-associated nonpointer PROTECTED object as a
+ // data-target or initial-data-target, while 8.5.16 NOTE 1 shows that
+ // association as valid for a PROTECTED_TARGET pointer. Follow NOTE 1: the
+ // target cannot be defined through such a pointer, so do not warn about an
+ // undefinable target.
+ if (!isProtectedTarget_ &&
+ !(isDummyArgument_ && isIntrinsic_ && 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;
@@ -614,7 +668,7 @@ bool CheckStructConstructorPointerComponent(SemanticsContext &context,
bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
const std::string &description, const DummyDataObject &lhs,
const SomeExpr &rhs, const Scope &scope, bool isAssumedRank,
- bool isPointerActualArgument) {
+ bool isPointerActualArgument, bool isIntrinsic) {
return PointerAssignmentChecker{context, scope, source, description}
.set_lhsType(common::Clone(lhs.type))
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
@@ -622,6 +676,10 @@ bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
.set_isAssumedRank(isAssumedRank)
.set_isRHSPointerActualArgument(isPointerActualArgument)
.set_ignoreTKR(lhs.ignoreTKR)
+ .set_isProtectedTarget(
+ lhs.attrs.test(DummyDataObject::Attr::ProtectedTarget))
+ .set_isDummyArgument(true)
+ .set_isIntrinsic(isIntrinsic)
.Check(rhs);
}
diff --git a/flang/lib/Semantics/pointer-assignment.h b/flang/lib/Semantics/pointer-assignment.h
index ad7c6554d5a13..9115fcaec76d5 100644
--- a/flang/lib/Semantics/pointer-assignment.h
+++ b/flang/lib/Semantics/pointer-assignment.h
@@ -31,7 +31,8 @@ bool CheckPointerAssignment(SemanticsContext &, const SomeExpr &lhs,
bool CheckPointerAssignment(SemanticsContext &, parser::CharBlock source,
const std::string &description,
const evaluate::characteristics::DummyDataObject &, const SomeExpr &rhs,
- const Scope &, bool isAssumedRank, bool IsPointerActualArgument);
+ const Scope &, bool isAssumedRank, bool IsPointerActualArgument,
+ bool isIntrinsic = false);
bool CheckStructConstructorPointerComponent(
SemanticsContext &, const Symbol &lhs, const SomeExpr &rhs, const Scope &);
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 3571a1de521f7..41060bd7a44a5 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);
@@ -9334,6 +9339,8 @@ void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
if (auto expr{EvaluateIntExpr(*rankValue)}) {
if (auto val{evaluate::ToInt64(*expr)}) {
details.set_rank(*val);
+ // F'2028 11.1.12.3p3 keeps ALLOCATABLE, POINTER and TARGET for
+ // RANK (n), not PROTECTED_TARGET (RANK DEFAULT keeps all attributes).
attrsToKeep |= Attrs{Attr::ALLOCATABLE, Attr::POINTER};
} else {
Say("RANK() expression must be constant"_err_en_US);
@@ -9346,7 +9353,8 @@ void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
CHECK(std::holds_alternative<parser::Default>(x.u));
// RANK DEFAULT: assumed-rank
details.set_IsAssumedRank();
- attrsToKeep |= Attrs{Attr::ALLOCATABLE, Attr::POINTER};
+ attrsToKeep |=
+ Attrs{Attr::ALLOCATABLE, Attr::POINTER, Attr::PROTECTED_TARGET};
}
symbol->attrs() |= selectorAttrs & attrsToKeep;
}
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 48ff27f214649..aedd3e310f1bc 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -9,6 +9,7 @@
#include "flang/Parser/tools.h"
#include "flang/Common/indirection.h"
#include "flang/Evaluate/characteristics.h"
+#include "flang/Evaluate/tools.h"
#include "flang/Parser/dump-parse-tree.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parse-tree.h"
@@ -1992,4 +1993,54 @@ bool AreSameModuleSymbol(const Symbol &symbol, const Symbol &other) {
other.owner().IsModule() && symbol.owner().GetName() &&
symbol.owner().GetName() == other.owner().GetName();
}
+
+// The nearest pointer in the designator decides (F'2023 9.4.2p5, as in
+// DefinesComponentPointerTarget). When defining a pointer component, start
+// from the component's base.
+const Symbol *FindProtectedTargetPointer(
+ const evaluate::DataRef &dataRef, bool isPointerDefinition) {
+ const Symbol *lastPtr{nullptr};
+ if (isPointerDefinition) {
+ if (const auto *comp{std::get_if<evaluate::Component>(&dataRef.u)}) {
+ lastPtr = evaluate::GetLastPointerSymbol(comp->base());
+ } else if (const auto *aRef{std::get_if<evaluate::ArrayRef>(&dataRef.u)}) {
+ if (const auto *comp{aRef->base().UnwrapComponent()}) {
+ lastPtr = evaluate::GetLastPointerSymbol(comp->base());
+ } else {
+ return nullptr;
+ }
+ } else {
+ return nullptr;
+ }
+ } else {
+ lastPtr = evaluate::GetLastPointerSymbol(dataRef);
+ }
+ if (lastPtr) {
+ const Symbol &ultimate{lastPtr->GetUltimate()};
+ return IsProtectedTarget(ultimate) ? lastPtr : nullptr;
+ }
+ return nullptr;
+}
+
+const Symbol *FindProtectedTargetPointer(
+ const SomeExpr &expr, bool isPointerDefinition) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
+ return FindProtectedTargetPointer(*dataRef, isPointerDefinition);
+ }
+ if (!isPointerDefinition) {
+ // Treat a function reference returning a PROTECTED_TARGET pointer as that
+ // pointer for F'2028 C870-C874 and 8.5.16p2 (the result entity has the
+ // attribute).
+ if (const auto *procRef{evaluate::UnwrapProcedureRef(expr)}) {
+ if (const Symbol *procSym{procRef->proc().GetSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*procSym)}) {
+ if (IsProtectedTarget(result->GetUltimate())) {
+ return &procSym->GetUltimate();
+ }
+ }
+ }
+ }
+ }
+ return nullptr;
+}
} // namespace Fortran::semantics
diff --git a/flang/test/Parser/unparse-protected-target-fixed.f b/flang/test/Parser/unparse-protected-target-fixed.f
new file mode 100644
index 0000000000000..1557930364fa7
--- /dev/null
+++ b/flang/test/Parser/unparse-protected-target-fixed.f
@@ -0,0 +1,17 @@
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s
+
+ subroutine test_fixed
+ integer, pointer, protected_target :: p1
+ integer, pointer :: p2
+ integer, pointer :: p3
+ protected_target :: p2
+ protected_target p3
+ end subroutine
+
+! CHECK: SUBROUTINE test_fixed
+! CHECK: INTEGER, POINTER, PROTECTED_TARGET :: p1
+! CHECK: INTEGER, POINTER :: p2
+! CHECK: INTEGER, POINTER :: p3
+! CHECK: PROTECTED_TARGET :: p2
+! CHECK: PROTECTED_TARGET :: p3
+! CHECK: END SUBROUTINE
diff --git a/flang/test/Parser/unparse-protected-target.f90 b/flang/test/Parser/unparse-protected-target.f90
new file mode 100644
index 0000000000000..55c0a3fcfa75e
--- /dev/null
+++ b/flang/test/Parser/unparse-protected-target.f90
@@ -0,0 +1,27 @@
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s
+
+subroutine test_unparse()
+ type t
+ integer, pointer, protected_target :: c
+ end type
+ integer, pointer, protected_target :: p1
+ integer, protected :: prot_var
+ integer, pointer :: p2
+ integer, pointer :: p3
+ protected_target :: p2
+ protected_target p3
+ protected :: prot_var2
+end subroutine
+
+! CHECK: SUBROUTINE test_unparse
+! CHECK: TYPE :: t
+! CHECK: INTEGER, POINTER, PROTECTED_TARGET :: c
+! CHECK: END TYPE
+! CHECK: INTEGER, POINTER, PROTECTED_TARGET :: p1
+! CHECK: INTEGER, PROTECTED :: prot_var
+! CHECK: INTEGER, POINTER :: p2
+! CHECK: INTEGER, POINTER :: p3
+! CHECK: PROTECTED_TARGET :: p2
+! CHECK: PROTECTED_TARGET :: p3
+! CHECK: PROTECTED :: prot_var2
+! CHECK: END SUBROUTINE
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..da1d4b4ac555a
--- /dev/null
+++ b/flang/test/Semantics/OpenMP/lastprivate-protected-target.f90
@@ -0,0 +1,57 @@
+! RUN: %python %S/../test_errors.py %s %flang -fopenmp
+! Test that a pointer with the PROTECTED_TARGET attribute is accepted in
+! a LASTPRIVATE clause (updated as if by pointer assignment per OpenMP 5.2
+! section 5.4.5), while REDUCTION is rejected (defines target) and INTENT(IN)
+! remains rejected.
+
+subroutine omp_lastprivate_pt(p_in)
+ integer, pointer, protected_target, intent(in) :: p_in
+ integer, pointer, protected_target :: p
+ integer, pointer, protected_target :: q
+ integer, target :: t(10)
+ integer :: i
+
+ ! A pointer with PROTECTED_TARGET is permitted on LASTPRIVATE
+ !$omp parallel do lastprivate(p)
+ do i = 1, 10
+ p => t(i)
+ p => q
+ end do
+ !$omp end parallel do
+
+ !$omp parallel
+ !$omp do lastprivate(p)
+ do i = 1, 10
+ p => t(i)
+ end do
+ !$omp end do
+ !$omp end parallel
+
+ !$omp sections lastprivate(p)
+ !$omp section
+ p => t(1)
+ !$omp end sections
+
+ ! The PROTECTED_TARGET attribute of p also applies inside data-sharing
+ ! regions, so it may be associated with another PROTECTED_TARGET pointer
+ !$omp parallel private(p)
+ p => q
+ !$omp end parallel
+
+ !$omp parallel
+ p => q
+ !$omp end parallel
+
+ ! REDUCTION defines the target, so it must be rejected
+ !ERROR: Variable 'p' on the REDUCTION clause is not definable
+ !BECAUSE: The target of 'p' with the PROTECTED_TARGET attribute may not be defined
+ !$omp parallel do reduction(+:p)
+ do i = 1, 10
+ end do
+
+ ! INTENT(IN) pointer remains rejected on LASTPRIVATE
+ !ERROR: Pointer 'p_in' with the INTENT(IN) attribute may not appear in a LASTPRIVATE clause
+ !$omp parallel do lastprivate(p_in)
+ do i = 1, 10
+ end do
+end subroutine
diff --git a/flang/test/Semantics/modfile-protected-target-read.f90 b/flang/test/Semantics/modfile-protected-target-read.f90
new file mode 100644
index 0000000000000..50396c0f056e2
--- /dev/null
+++ b/flang/test/Semantics/modfile-protected-target-read.f90
@@ -0,0 +1,59 @@
+! RUN: split-file %s %t
+! RUN: %flang_fc1 -fsyntax-only -module-dir %t %t/def.f90
+! RUN: not %flang_fc1 -fsyntax-only -module-dir %t %t/use.f90 2>&1 | FileCheck %s
+
+!--- def.f90
+module mod_pt_def
+ type sub_t
+ integer :: a
+ integer, pointer, protected_target :: pt_comp
+ end type
+ integer, pointer, protected_target :: p_var
+contains
+ subroutine sub_pt_dummy(arg)
+ integer, pointer, protected_target :: arg
+ end subroutine
+ subroutine sub_ord_dummy(arg)
+ integer, pointer :: arg
+ end subroutine
+ subroutine sub_no_intent(arg)
+ integer :: arg
+ end subroutine
+end module
+
+!--- use.f90
+subroutine test_use_readback()
+ use mod_pt_def
+ integer, target :: tgt = 1
+ integer, pointer :: ord_p
+ type(sub_t) :: s
+
+ ! C866: assignment through read-back PROTECTED_TARGET pointer variable
+ ! CHECK: error: Left-hand side of assignment is not definable
+ ! CHECK: because: The target of 'p_var' with the PROTECTED_TARGET attribute may not be defined
+ p_var = 10
+
+ ! C866: assignment through read-back PROTECTED_TARGET component
+ ! CHECK: error: Left-hand side of assignment is not definable
+ ! CHECK: because: The target of 'pt_comp' with the PROTECTED_TARGET attribute may not be defined
+ s%pt_comp = 20
+
+ ! C870: ordinary pointer target dropped protection
+ ! CHECK: error: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_p => p_var
+
+ ! C870: component form
+ ! CHECK: error: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_p => s%pt_comp
+
+ ! C872: passing PROTECTED_TARGET to non-PROTECTED_TARGET pointer dummy
+ ! CHECK: error: dummy argument 'arg=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call sub_ord_dummy(p_var)
+
+ ! C872: passing PROTECTED_TARGET actual to PROTECTED_TARGET dummy is conforming
+ call sub_pt_dummy(p_var)
+
+ ! C874: passing PROTECTED_TARGET to non-pointer dummy without INTENT(IN)
+ ! CHECK: error: Actual argument associated with dummy argument 'arg=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call sub_no_intent(p_var)
+end subroutine
diff --git a/flang/test/Semantics/modfile-protected-target.f90 b/flang/test/Semantics/modfile-protected-target.f90
new file mode 100644
index 0000000000000..61986c3e652d0
--- /dev/null
+++ b/flang/test/Semantics/modfile-protected-target.f90
@@ -0,0 +1,31 @@
+! Test modfile emission and readback for PROTECTED_TARGET attribute
+! RUN: %python %S/test_modfile.py %s %flang_fc1
+
+module m1
+ type :: t
+ integer, pointer, protected_target :: c
+ end type
+ integer, pointer, protected_target :: p
+contains
+ subroutine sub(arg)
+ integer, pointer, protected_target :: arg
+ end subroutine
+ function func() result(r)
+ integer, pointer, protected_target :: r
+ end function
+end module m1
+
+!Expect: m1.mod
+!module m1
+!type::t
+!integer(4),pointer,protected_target::c
+!end type
+!integer(4),pointer,protected_target::p
+!contains
+!subroutine sub(arg)
+!integer(4),pointer,protected_target::arg
+!end
+!function func() result(r)
+!integer(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..c64303ed52383
--- /dev/null
+++ b/flang/test/Semantics/protected_target01.f90
@@ -0,0 +1,616 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Fortran 2028 PROTECTED_TARGET constraint checks (C781, C8109, C866-C874)
+
+module m_pt_constraints
+ ! C781: Component with PROTECTED_TARGET must also have POINTER
+ type t_comp
+ !ERROR: PROTECTED_TARGET component 'c' must have the POINTER attribute
+ integer, protected_target :: c
+ end type
+
+ ! C8109, 8.5.16p1: Entity must be a data pointer
+ !ERROR: PROTECTED_TARGET entity 'bad_var' must be a data pointer
+ integer, protected_target :: bad_var
+ !ERROR: PROTECTED_TARGET entity 'bad_alloc' must be a data pointer
+ integer, allocatable, protected_target :: bad_alloc
+ !ERROR: PROTECTED_TARGET entity 'bad_param' must be a data pointer
+ integer, parameter, protected_target :: bad_param = 1
+ !ERROR: PROTECTED_TARGET entity 'bad_target' must be a data pointer
+ integer, target, protected_target :: bad_target
+
+ !ERROR: PROTECTED_TARGET entity 'bad_stmt_var' must be a data pointer
+ integer :: bad_stmt_var
+ protected_target :: bad_stmt_var
+
+ abstract interface
+ subroutine sub_iface(); end subroutine
+ end interface
+ !ERROR: PROTECTED_TARGET entity 'bad_proc_p' must be a data pointer
+ procedure(sub_iface), pointer :: bad_proc_p
+ protected_target :: bad_proc_p
+
+ ! C867: COMMON block restriction
+ !ERROR: A pointer 'common_p' with the PROTECTED_TARGET attribute may not be in a COMMON block
+ integer, pointer, protected_target :: common_p
+ common /cblock/ common_p
+
+ type sub_t
+ integer :: a
+ integer, pointer :: pc
+ integer, pointer, protected_target :: ptc2 => null()
+ integer, allocatable :: al(:)
+ end type
+
+ type container_t
+ type(sub_t), pointer, protected_target :: ptc
+ end type
+
+ type int_ptr_comp_t
+ integer, pointer, protected_target :: ptc
+ end type
+
+ type poly_comp_t
+ class(*), pointer, protected_target :: cp
+ end type
+
+contains
+ function get_pt() result(r)
+ integer, pointer, protected_target :: r
+ end function
+
+ function func_pt() result(r)
+ integer, pointer, protected_target :: r
+ r => null()
+ end function
+
+ function func_ord() result(r)
+ integer, pointer :: r
+ r => null()
+ end function
+
+ subroutine test_checks(tgt, tgt_arr)
+ integer, target :: tgt
+ integer, target :: tgt_arr(2)
+ integer, pointer, protected_target :: p_int
+ real, pointer, protected_target :: p_real
+ integer, pointer, protected_target :: p_arr(:)
+ type(sub_t), pointer, protected_target :: p_sub
+ type(container_t) :: x
+ type(container_t) :: xa(2)
+ type(container_t), pointer :: op_sub
+ type(int_ptr_comp_t), pointer :: op_int
+ type(poly_comp_t), pointer :: op_poly
+ type(int_ptr_comp_t) :: x_int
+ integer, pointer :: ord_int
+ integer, pointer :: ord_arr(:)
+ type(sub_t), pointer :: ord_sub
+ class(*), pointer, protected_target :: poly_pt
+ character(:), pointer, protected_target :: cp
+ complex, pointer, protected_target :: zp
+ integer, allocatable :: tmp(:)
+ procedure(get_pt), pointer :: fp
+ integer, pointer :: p_no_colon
+ protected_target p_no_colon
+ external :: implicit_sub
+ namelist /nl_pt/ p_int
+
+ ! C868: DEALLOCATE statement
+ !ERROR: A pointer with the PROTECTED_TARGET attribute may not be an allocate-object in a DEALLOCATE statement
+ deallocate(p_int)
+ !ERROR: A pointer with the PROTECTED_TARGET attribute may not be an allocate-object in a DEALLOCATE statement
+ deallocate(x%ptc)
+ !ERROR: A pointer with the PROTECTED_TARGET attribute may not be an allocate-object in a DEALLOCATE statement
+ deallocate(xa(1)%ptc)
+
+ ! C869: ALLOCATE without SOURCE=
+ !ERROR: An ALLOCATE statement for a pointer with the PROTECTED_TARGET attribute must have a SOURCE= clause
+ allocate(p_int)
+ !ERROR: An ALLOCATE statement for a pointer with the PROTECTED_TARGET attribute must have a SOURCE= clause
+ allocate(p_int, mold=tgt)
+ !ERROR: An ALLOCATE statement for a pointer with the PROTECTED_TARGET attribute must have a SOURCE= clause
+ allocate(x%ptc)
+
+ ! C866 & 8.5.16p2: Definability
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ p_int = 2
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'p_arr' with the PROTECTED_TARGET attribute may not be defined
+ p_arr(1:2) = 3
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ p_sub%a = 4
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ x%ptc%a = 5
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ x%ptc = sub_t(1, null())
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ p_sub%pc => tgt
+ !ERROR: 'pc' may not appear in NULLIFY
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ nullify(p_sub%pc)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ allocate(p_sub%pc)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ allocate(p_sub%al(2))
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ deallocate(p_sub%al)
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'from=' is not definable
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ call move_alloc(p_sub%al, tmp)
+ !ERROR: Internal file variable 'cp' is not definable
+ !BECAUSE: The target of 'cp' with the PROTECTED_TARGET attribute may not be defined
+ write(cp, '(a)') 'x'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'cp' with the PROTECTED_TARGET attribute may not be defined
+ cp(1:2) = 'ab'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'zp' with the PROTECTED_TARGET attribute may not be defined
+ zp%re = 1.0
+ !ERROR: Input variable 'p_int' is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ read *, p_int
+ !ERROR: STAT variable 'p_int' is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ allocate(ord_int, stat=p_int)
+ !ERROR: 'p_int' may not be used as a DO variable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ do p_int = 1, 2
+ end do
+ !ERROR: NAMELIST input group must not contain undefinable item 'p_int'
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ read(*, nml=nl_pt)
+ !ERROR: IOSTAT variable 'p_int' is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ read(*, *, iostat=p_int) tgt
+ !ERROR: IOLENGTH variable 'p_int' is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ inquire(iolength=p_int) tgt
+
+ associate(assoc_p => p_int)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ assoc_p = 5
+ ! An associate name is not a pointer with the PROTECTED_TARGET attribute,
+ ! so C870, C873, and C874 do not apply to it.
+ ord_int => assoc_p
+ call implicit_sub(assoc_p)
+ call sub_no_intent(assoc_p)
+ end associate
+
+ associate(assoc_sub => p_sub)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ assoc_sub%pc => tgt
+ !ERROR: 'pc' may not appear in NULLIFY
+ !BECAUSE: The target of 'p_sub' with the PROTECTED_TARGET attribute may not be defined
+ nullify(assoc_sub%pc)
+ end associate
+
+ select type (a => poly_pt)
+ type is (integer)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'poly_pt' with the PROTECTED_TARGET attribute may not be defined
+ a = 42
+ end select
+
+ associate(b => op_int%ptc)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ b = 2
+ ord_int => b
+ end associate
+
+ associate(a => x_int%ptc)
+ !ERROR: 'a' may not be used as a DO variable
+ !BECAUSE: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ do a = 1, 2
+ end do
+ !ERROR: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ read(*, *) (tgt, a = 1, 2)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ a = 3
+ end associate
+
+ associate(b_pt => p_int)
+ !ERROR: 'b_pt' may not be used as a DO variable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ do b_pt = 1, 2
+ end do
+ end associate
+
+ associate(b => op_sub%ptc)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ b%pc => tgt
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ b%a = 1
+ !ERROR: 'pc' may not appear in NULLIFY
+ !BECAUSE: The target of 'ptc' with the PROTECTED_TARGET attribute may not be defined
+ nullify(b%pc)
+ end associate
+
+ select type (c => op_poly%cp)
+ type is (integer)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'cp' with the PROTECTED_TARGET attribute may not be defined
+ c = 5
+ end select
+
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'p_no_colon' with the PROTECTED_TARGET attribute may not be defined
+ p_no_colon = 10
+
+ ! 8.5.16p2: Defining through function result returning PROTECTED_TARGET
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'get_pt' with the PROTECTED_TARGET attribute may not be defined
+ get_pt() = 5
+
+ fp => get_pt
+ !ERROR: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_int => fp()
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'fp' with the PROTECTED_TARGET attribute may not be defined
+ fp() = 6
+
+ ! C870: Pointer assignment dropping protection
+ !ERROR: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_int => p_int
+ !ERROR: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_arr => p_arr(1:2)
+ !ERROR: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_int => p_sub%a
+ !ERROR: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_sub => x%ptc
+ !ERROR: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_int => get_pt()
+
+ ! C871: Structure constructor dropping protection
+ call test_ctor(p_sub, p_arr)
+
+ ! C872: Pointer dummy argument without PROTECTED_TARGET
+ !ERROR: dummy argument 'arg=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call sub_ord_ptr(p_int)
+ !ERROR: dummy argument 'arg=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call sub_ord_ptr(p_sub%pc)
+ !ERROR: dummy argument 'arg=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call sub_ord_ptr(p_sub%ptc2)
+ !ERROR: dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call ptr_in(p_arr(1))
+ !ERROR: dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call ptr_in(p_sub%a)
+ !ERROR: dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call ptr_in(p_sub%pc)
+ call sub_pt_ptr(p_sub%pc)
+
+ ! C873: Implicit interface actual argument
+ !ERROR: A pointer with the PROTECTED_TARGET attribute (or a subobject thereof) may not be passed to a procedure with an implicit interface
+ call implicit_sub(p_int)
+ !ERROR: A pointer with the PROTECTED_TARGET attribute (or a subobject thereof) may not be passed to a procedure with an implicit interface
+ call implicit_sub(p_sub%a)
+ !ERROR: A pointer with the PROTECTED_TARGET attribute (or a subobject thereof) may not be passed to a procedure with an implicit interface
+ call implicit_sub(p_arr(1))
+
+ ! C874: Non-pointer dummy argument without INTENT(IN)
+ !ERROR: Actual argument associated with dummy argument 'arg=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call sub_no_intent(p_int)
+ !ERROR: Actual argument associated with dummy argument 'arg=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call sub_no_intent(p_arr(1))
+ !ERROR: Actual argument associated with dummy argument 'arg=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call sub_no_intent(p_sub%a)
+ !ERROR: Actual argument associated with dummy argument 'arg=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call sub_no_intent_arr(p_arr(1:2))
+ !ERROR: Actual argument associated with dummy argument 'arg=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call sub_value(p_int)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'arg=' is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ call sub_intent_out(p_int)
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'arg=' is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ call sub_intent_inout(p_int)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'harvest=' is not definable
+ !BECAUSE: The target of 'p_real' with the PROTECTED_TARGET attribute may not be defined
+ call random_number(p_real)
+
+ call test_host_assoc()
+ contains
+ subroutine test_host_assoc()
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'p_int' with the PROTECTED_TARGET attribute may not be defined
+ p_int = 100
+ !ERROR: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord_int => p_int
+ end subroutine
+ end subroutine
+
+ subroutine test_ctor(p, pa)
+ type(sub_t), pointer, protected_target :: p
+ integer, pointer, protected_target :: pa(:)
+ type t_ctor
+ type(sub_t), pointer :: c
+ end type
+ type t_ctor_arr
+ integer, pointer :: arr(:)
+ integer, pointer :: scalar
+ end type
+ type(t_ctor) :: res
+ type(t_ctor_arr) :: res2
+ !ERROR: A structure constructor component must have the PROTECTED_TARGET attribute when the value is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ res = t_ctor(p)
+ !ERROR: A structure constructor component must have the PROTECTED_TARGET attribute when the value is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ res = t_ctor(c=p)
+ !ERROR: A structure constructor component must have the PROTECTED_TARGET attribute when the value is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ res2 = t_ctor_arr(arr=pa(1:2), scalar=p%pc)
+ end subroutine
+
+ subroutine sub_ord_ptr(arg)
+ integer, pointer :: arg
+ end subroutine
+
+ subroutine ptr_in(a)
+ integer, pointer, intent(in) :: a
+ end subroutine
+
+ subroutine sub_pt_ptr(arg)
+ integer, pointer, protected_target :: arg
+ end subroutine
+
+ subroutine sub_no_intent(arg)
+ integer :: arg
+ end subroutine
+
+ subroutine sub_no_intent_arr(arg)
+ integer :: arg(:)
+ end subroutine
+
+ subroutine sub_intent_out(arg)
+ integer, intent(out) :: arg
+ end subroutine
+
+ subroutine sub_intent_inout(arg)
+ integer, intent(inout) :: arg
+ end subroutine
+
+ subroutine sub_value(arg)
+ integer, value :: arg
+ end subroutine
+
+ subroutine test_coarray()
+ use iso_fortran_env, only: team_type, lock_type
+ type(team_type), pointer, protected_target :: tm
+ logical, pointer, protected_target :: pl
+ type(lock_type), save :: lk[*]
+ !ERROR: Team-variable is not definable
+ !BECAUSE: The target of 'tm' with the PROTECTED_TARGET attribute may not be defined
+ form team(1, tm)
+ !ERROR: ACQUIRED_LOCK= variable is not definable
+ !BECAUSE: The target of 'pl' with the PROTECTED_TARGET attribute may not be defined
+ lock(lk, acquired_lock=pl)
+ end subroutine
+
+ subroutine test_c_f_pointer(cp, p)
+ use iso_c_binding
+ type(c_ptr) :: cp
+ integer, pointer, protected_target :: p(:)
+ ! C872 is not applied to intrinsic procedures: intrinsic pointer dummy
+ ! arguments (e.g. FPTR of C_F_POINTER) only inquire or set association
+ ! and never define the target through the pointer.
+ call c_f_pointer(cp, p, [1])
+ end subroutine
+
+ subroutine test_pt_intent_reassoc(p, tgt)
+ integer, pointer, protected_target, intent(in) :: p
+ integer, target :: tgt
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ p => tgt
+ !ERROR: 'p' may not appear in NULLIFY
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ nullify(p)
+ end subroutine
+
+ subroutine test_proc_ptr_characteristics()
+ abstract interface
+ subroutine iface_pt(q)
+ integer, pointer, protected_target :: q
+ end subroutine
+ subroutine iface_ord(q)
+ integer, pointer :: q
+ end subroutine
+ function iface_f_pt() result(r)
+ integer, pointer, protected_target :: r
+ end function
+ function iface_f_ord() result(r)
+ integer, pointer :: r
+ end function
+ end interface
+ procedure(iface_pt), pointer :: pp_pt
+ procedure(iface_ord), pointer :: pp_ord
+ procedure(iface_f_pt), pointer :: pp_f_pt
+ procedure(iface_f_ord), pointer :: pp_f_ord
+
+ ! Procedure pointer assignment both directions accepted.
+ ! The unsafe direction (interface expecting a PROTECTED_TARGET dummy
+ ! associated with an ordinary pointer target) is permitted because
+ ! PROTECTED_TARGET is not a procedure characteristic in Fortran 2028
+ ! (J3/26-007r1 15.3.2.2 and 15.3.3).
+ pp_pt => pp_ord
+ pp_ord => pp_pt
+
+ ! Function result compatibility both directions accepted
+ pp_f_pt => pp_f_ord
+ pp_f_ord => pp_f_pt
+ pp_f_pt => func_ord
+ pp_f_ord => func_pt
+
+ call call_dummy(pp_ord)
+ call call_dummy(pp_pt)
+ contains
+ subroutine call_dummy(dproc)
+ procedure(iface_pt) :: dproc
+ end subroutine
+ end subroutine
+
+ subroutine test_do_concurrent()
+ integer, pointer, protected_target :: p
+ integer :: i
+ !ERROR: 'p' may not appear in a locality-spec because it is not definable
+ !BECAUSE: The target of 'p' with the PROTECTED_TARGET attribute may not be defined
+ do concurrent (i=1:2) local(p)
+ end do
+ end subroutine
+end module
+
+module m_pt_rename_src
+ integer, target :: tgt = 1
+ integer, pointer, protected_target :: src_pt
+end module
+
+module m_pt_rename_test
+ use m_pt_rename_src, only: ren_pt => src_pt
+contains
+ subroutine test_rename()
+ integer, pointer :: ord
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'ren_pt' with the PROTECTED_TARGET attribute may not be defined
+ ren_pt = 1
+ !ERROR: Data pointer object must have the PROTECTED_TARGET attribute when the target is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ ord => ren_pt
+ end subroutine
+end module
+
+module m_generic_pt
+ type s_gen
+ integer, pointer :: pc
+ end type
+ interface gen_elem
+ module procedure s_arr
+ module procedure s_elem
+ end interface
+ interface gen_plain
+ module procedure s_int
+ module procedure s_real
+ end interface
+ interface gen_ptr
+ module procedure s_ord_ptr
+ module procedure s_real_ptr
+ end interface
+contains
+ subroutine s_arr(x)
+ integer :: x(:)
+ x = 0
+ end subroutine
+ elemental subroutine s_elem(x)
+ integer, intent(in) :: x
+ end subroutine
+ subroutine s_int(x)
+ integer :: x
+ end subroutine
+ subroutine s_real(x)
+ real :: x
+ end subroutine
+ subroutine s_ord_ptr(x)
+ integer, pointer :: x
+ end subroutine
+ subroutine s_real_ptr(x)
+ real, pointer :: x
+ end subroutine
+ subroutine test_generic()
+ integer, pointer, protected_target :: p(:)
+ integer, pointer, protected_target :: p_scalar
+ type(s_gen), pointer, protected_target :: p_sub
+ ! C874: elemental vs nonelemental resolves to nonelemental specific, which violates C874
+ !ERROR: Actual argument associated with dummy argument 'x=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call gen_elem(p)
+ ! C874: plain generic reports C874 on matching specific, not "no specific matches"
+ !ERROR: Actual argument associated with dummy argument 'x=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call gen_plain(p_scalar)
+ ! C872: generic interface reports C872 on matching specific, not "no specific matches"
+ !ERROR: dummy argument 'x=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call gen_ptr(p_sub%pc)
+ end subroutine
+end module
+
+module m_tbp_override
+ type base
+ contains
+ procedure, nopass :: tb => tb_base
+ end type
+ type, extends(base) :: ext
+ contains
+ procedure, nopass :: tb => tb_ext
+ end type
+contains
+ subroutine tb_base(a)
+ integer, pointer :: a
+ end subroutine
+ subroutine tb_ext(a)
+ integer, pointer, protected_target :: a
+ end subroutine
+end module
+
+module m_sep_interface
+ interface
+ module subroutine sep(a)
+ integer, pointer :: a
+ end subroutine
+ ! 26-007r1 15.3.2.2: PROTECTED_TARGET is not a characteristic, so
+ ! the interface may declare it even if the module procedure body does not.
+ module subroutine sep_unsafe(a)
+ integer, pointer, protected_target :: a
+ end subroutine
+ end interface
+end module
+
+submodule (m_sep_interface) s_sep_interface
+contains
+ module subroutine sep(a)
+ integer, pointer, protected_target :: a
+ end subroutine
+ module subroutine sep_unsafe(a)
+ integer, pointer :: a
+ a = 999
+ end subroutine
+end submodule
+
+module m_select_rank_default
+contains
+ subroutine ord_ptr_ar(x)
+ integer, pointer :: x(..)
+ end subroutine
+ subroutine ord_ptr_1d(x)
+ integer, pointer :: x(:)
+ end subroutine
+ subroutine no_intent_ar(x)
+ integer :: x(..)
+ end subroutine
+ subroutine test_select_rank_default(pr)
+ integer, pointer, protected_target :: pr(..)
+ integer, pointer :: ord1(:)
+ select rank (r => pr)
+ rank (1)
+ ! J3/26-007r1 11.1.12.3p3: r is a pointer without PROTECTED_TARGET,
+ ! so C870 and C872 do not apply to it; it is still not definable.
+ ord1 => r
+ call ord_ptr_1d(r)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of 'pr' with the PROTECTED_TARGET attribute may not be defined
+ r(1) = 0
+ rank default
+ !ERROR: dummy argument 'x=' must have the PROTECTED_TARGET attribute when the actual argument is a pointer with the PROTECTED_TARGET attribute or a subobject thereof
+ call ord_ptr_ar(r)
+ !ERROR: Actual argument associated with dummy argument 'x=' is a pointer with the PROTECTED_TARGET attribute (or a subobject thereof) and must be associated with an INTENT(IN) dummy argument
+ call no_intent_ar(r)
+ !ERROR: A pointer with the PROTECTED_TARGET attribute may not be an allocate-object in a DEALLOCATE statement
+ deallocate(r)
+ end select
+ end subroutine
+end module
diff --git a/flang/test/Semantics/protected_target02.f90 b/flang/test/Semantics/protected_target02.f90
new file mode 100644
index 0000000000000..aba10c7a70b41
--- /dev/null
+++ b/flang/test/Semantics/protected_target02.f90
@@ -0,0 +1,176 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %flang_fc1 -fsyntax-only -Wpointer-to-undefinable %s 2>&1 | FileCheck %s --implicit-check-not="Pointer target is not a definable"
+! Positive tests for Fortran 2028 PROTECTED_TARGET
+
+module m_prot
+ integer, target, protected :: prot_target = 42
+end module
+
+module m_pt_positive
+ use m_prot
+ type sub_t
+ integer :: a = 10
+ integer, pointer :: pc => null()
+ end type
+
+ type container_t
+ type(sub_t), pointer, protected_target :: ptc => null()
+ end type
+
+ integer, target :: mod_target = 100
+ integer, pointer, protected_target :: mod_pt
+ integer, pointer, protected_target :: init_pt => prot_target
+
+contains
+ function get_pt() result(r)
+ integer, pointer, protected_target :: r
+ r => mod_target
+ end function
+
+ subroutine test_positive()
+ integer, target :: local_val = 1
+ integer, target :: local_arr(3) = [1, 2, 3]
+ type(sub_t), target :: local_sub
+ integer, pointer, protected_target :: p
+ integer, pointer, protected_target :: p_arr(:)
+ integer, pointer, protected_target :: q
+ class(*), pointer, protected_target :: poly_pt
+ type(sub_t), pointer, protected_target :: p_sub
+ type(container_t) :: cont
+ integer, pointer :: ord_ptr
+ integer :: val
+ logical :: l_assoc
+
+ ! 1. Pointer association to target (local and module)
+ p => local_val
+ mod_pt => mod_target
+ val = p + mod_pt
+
+ ! 2. 8.5.16 NOTE 1 vs C864: Pointer association to use-associated protected target
+ ! Draft J3/26-007r1 C864 forbids a use-associated nonpointer PROTECTED object
+ ! as a data-target, while 8.5.16 NOTE 1 shows it as valid for PROTECTED_TARGET.
+ ! Following NOTE 1, ordinary pointer gets warning under -Wpointer-to-undefinable;
+ ! PROTECTED_TARGET pointer does not (in pointer-assignment or initial-data-target).
+ ! CHECK: protected_target02.f90:[[@LINE+2]]:{{[0-9]+}}: warning: Pointer target is not a definable variable
+ ! CHECK: because: 'prot_target' is protected in this scope
+ ord_ptr => prot_target
+ p => prot_target
+ val = p + init_pt
+
+ ! Conforming NULL(MOLD=) with PROTECTED_TARGET pointer
+ p => null(p)
+ ord_ptr => null(p)
+
+ ! 3. Allocation with SOURCE=
+ allocate(p, source=99)
+ nullify(p)
+
+ ! 4. Pointer-to-pointer assignment preserving protection
+ q => p
+ p_arr => local_arr
+ q => p_arr(2)
+
+ ! 5. Calling procedure with matching PROTECTED_TARGET pointer dummy
+ call take_pt_ptr(p)
+
+ ! 6. Calling procedure with INTENT(IN) non-pointer dummy
+ call take_intent_in(p)
+ call take_intent_in(p_arr(1))
+
+ ! 7. Calling procedure with pointer INTENT(OUT) dummy
+ call take_pt_ptr_out(p)
+
+ ! 8. Structure constructor with PROTECTED_TARGET component
+ cont = container_t(p_sub)
+
+ ! 9. Function result with PROTECTED_TARGET
+ q => get_pt()
+
+ ! 10. Pointer component of target is ordinary pointer: can define its target.
+ ! Under J3/26-007r1 9.4.2p5 and NOTE 1, the target of X%P is not a subobject
+ ! of X. The pointer X%P is a subobject of X only in contexts that pertain
+ ! to its pointer association status. Thus, the target of p_sub%pc can be
+ ! defined or associated with an ordinary pointer.
+ p_sub%pc = 200
+ ord_ptr => p_sub%pc
+ val = ord_ptr
+
+ ! 11. Component pointer association and allocation
+ cont%ptc => local_sub
+ nullify(cont%ptc)
+ allocate(cont%ptc, source=local_sub)
+
+ ! 12. Target of an ordinary pointer component passed to non-pointer dummy.
+ ! Under 9.4.2p5 and NOTE 1, the target of p_sub%pc is not a subobject of p_sub,
+ ! so passing it in a non-pointer context is conforming.
+ call take_no_intent(p_sub%pc)
+
+ ! 13. Polymorphic PROTECTED_TARGET pointer in SELECT TYPE read
+ poly_pt => local_val
+ select type (a => poly_pt)
+ type is (integer)
+ val = a
+ end select
+
+ ! 14. Target of an ordinary pointer component through ASSOCIATE.
+ ! Under 9.4.2p5 and NOTE 1, pc is the nearest pointer in p_sub%pc, so its
+ ! target is not protected. Construct association preserves this.
+ associate (b => p_sub%pc)
+ ord_ptr => b
+ b = 3
+ end associate
+ associate (c => p_sub)
+ ord_ptr => c%pc
+ c%pc = 4
+ end associate
+
+ ! 15. Intrinsic inquiry ASSOCIATED accepts PROTECTED_TARGET pointer
+ l_assoc = associated(p)
+ l_assoc = associated(ord_ptr, p)
+ end subroutine
+
+ subroutine take_pt_ptr(arg)
+ integer, pointer, protected_target :: arg
+ integer :: x
+ x = arg
+ end subroutine
+
+ subroutine take_intent_in(arg)
+ integer, intent(in) :: arg
+ integer :: x
+ x = arg
+ end subroutine
+
+ subroutine take_pt_ptr_out(arg)
+ integer, pointer, protected_target, intent(out) :: arg
+ nullify(arg)
+ end subroutine
+
+ subroutine take_no_intent(arg)
+ integer :: arg
+ integer :: x
+ x = arg
+ end subroutine
+end module
+
+module m_pt_rename
+ use m_prot, only: ren_prot => prot_target
+contains
+ subroutine test_rename()
+ integer, pointer, protected_target :: p
+ integer :: val
+ p => ren_prot
+ val = p
+ end subroutine
+end module
+
+! C867 applies to pointers named in a COMMON statement; a sequence-type object
+! with a PROTECTED_TARGET pointer component in COMMON is accepted.
+subroutine test_common_seq()
+ type seq_t
+ sequence
+ integer, pointer, protected_target :: pc
+ end type
+ type(seq_t) :: obj
+ common /cc/ obj
+end subroutine
More information about the flang-commits
mailing list