[flang-commits] [flang] [flang] Implement the Fortran 2028 PROTECTED_TARGET attribute (PR #231047)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Sun Oct 11 16:17:54 PDT 2026
https://github.com/Saieiei created https://github.com/llvm/llvm-project/pull/231047
The Fortran 2028 working draft (J3/26-007r1, 8.5.16) adds the PROTECTED_TARGET
attribute for data pointers: the target cannot be defined through the pointer.
Flang failed to parse it.
Parse the attribute, the component attribute and the statement, keep it in
module files and in call checking, and report C781, C866-C874 and C8109 as
errors. "Or a subobject thereof" follows the F'2023 9.4.2p5 reading already in
definable.cpp: an object reached through another pointer component is not a
subobject. Nonpointers with the attribute are rejected, since 8.5.16 covers only
data pointers. C872 and C874 apply as written, so C_F_POINTER's FPTR and a VALUE
dummy without INTENT(IN) are rejected; intrinsic inquiry arguments and
NULL(MOLD=) are exempt.
The draft conflicts here: C864 forbids a use-associated nonpointer PROTECTED
variable as a data-target, but NOTE 1 shows `p => x` as valid for a
PROTECTED_TARGET pointer. Flang follows NOTE 1 and the US15 examples
(J3/25-182r1). The attribute is not a procedure characteristic in the draft, so
procedure pointers, dummy procedures and separate module procedures can drop it
without a diagnostic. The optional NOTE 2 diagnostic is not implemented.
Assisted-by: GitHub Copilot
>From efbadb8a189dea7c4060f090df279b986e08fa8c Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Sun, 11 Oct 2026 18:17:41 -0500
Subject: [PATCH] [flang] Implement the Fortran 2028 PROTECTED_TARGET attribute
The Fortran 2028 working draft (J3/26-007r1, 8.5.16) adds the
PROTECTED_TARGET attribute for data pointers: the target cannot be
defined through the pointer. Flang failed to parse it.
Parse the attribute, the component attribute and the statement, keep it
in module files and in call checking, and report C781, C866-C874 and
C8109 as errors. "Or a subobject thereof" follows the F'2023 9.4.2p5
reading already in definable.cpp: an object reached through another
pointer component is not a subobject. Nonpointers with the attribute are
rejected, since 8.5.16 covers only data pointers. C872 and C874 apply as
written, so C_F_POINTER's FPTR and a VALUE dummy without INTENT(IN) are
rejected; intrinsic inquiry arguments and NULL(MOLD=) are exempt.
The draft conflicts here: C864 forbids a use-associated nonpointer
PROTECTED variable as a data-target, but NOTE 1 shows `p => x` as valid
for a PROTECTED_TARGET pointer. Flang follows NOTE 1 and the US15
examples (J3/25-182r1). The attribute is not a procedure characteristic
in the draft, so procedure pointers, dummy procedures and separate
module procedures can drop it without a diagnostic. The optional NOTE 2
diagnostic is not implemented.
Assisted-by: GitHub Copilot
---
flang/docs/ReleaseNotes.md | 6 +
.../include/flang/Evaluate/characteristics.h | 10 +-
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 27 +-
flang/include/flang/Semantics/attr.h | 4 +-
flang/include/flang/Semantics/tools.h | 9 +
flang/lib/Evaluate/characteristics.cpp | 30 +-
flang/lib/Parser/Fortran-parsers.cpp | 13 +-
flang/lib/Parser/misc-parsers.h | 2 +
flang/lib/Parser/program-parsers.cpp | 5 +-
flang/lib/Parser/unparse.cpp | 4 +
flang/lib/Semantics/check-allocate.cpp | 7 +
flang/lib/Semantics/check-call.cpp | 84 ++-
flang/lib/Semantics/check-deallocate.cpp | 10 +
flang/lib/Semantics/check-declarations.cpp | 25 +
flang/lib/Semantics/definable.cpp | 65 ++
flang/lib/Semantics/definable.h | 1 +
flang/lib/Semantics/pointer-assignment.cpp | 64 +-
flang/lib/Semantics/resolve-names.cpp | 12 +-
flang/lib/Semantics/tools.cpp | 57 ++
flang/test/Parser/protected-target.f90 | 29 +
.../Semantics/modfile-protected-target.f90 | 47 ++
.../protected-target-characteristics.f90 | 131 ++++
.../Semantics/protected-target-conflict.f90 | 40 ++
.../protected-target-function-result.f90 | 48 ++
.../protected-target-modfile-use.f90 | 61 ++
.../Semantics/protected-target-override.f90 | 31 +
flang/test/Semantics/protected-target.f90 | 566 ++++++++++++++++++
28 files changed, 1359 insertions(+), 31 deletions(-)
create mode 100644 flang/test/Parser/protected-target.f90
create mode 100644 flang/test/Semantics/modfile-protected-target.f90
create mode 100644 flang/test/Semantics/protected-target-characteristics.f90
create mode 100644 flang/test/Semantics/protected-target-conflict.f90
create mode 100644 flang/test/Semantics/protected-target-function-result.f90
create mode 100644 flang/test/Semantics/protected-target-modfile-use.f90
create mode 100644 flang/test/Semantics/protected-target-override.f90
create mode 100644 flang/test/Semantics/protected-target.f90
diff --git a/flang/docs/ReleaseNotes.md b/flang/docs/ReleaseNotes.md
index 609ca499da396..0250c2283733b 100644
--- a/flang/docs/ReleaseNotes.md
+++ b/flang/docs/ReleaseNotes.md
@@ -169,6 +169,12 @@ page](https://llvm.org/releases/).
`SIMPLE` constraints, or give the pointer or dummy an explicit `PURE`
interface.
+- Flang now accepts the `PROTECTED_TARGET` attribute and statement from the
+ Fortran 2028 working draft and enforces its constraints at compile time.
+ The target of such a pointer cannot be defined through it. Where the draft's
+ C864 and NOTE 1 conflict, Flang follows NOTE 1 and accepts associating such a
+ pointer with a use-associated `PROTECTED` variable.
+
## Build System Changes
## New Issues Found
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 1ba0bf693c763..7e89547ecc560 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -234,10 +234,14 @@ class TypeAndShape {
// 15.3.2.2
struct DummyDataObject {
ENUM_CLASS(Attr, Optional, Allocatable, Asynchronous, Contiguous, Value,
- Volatile, Pointer, Target, DeducedFromActual, OnlyIntrinsicInquiry)
+ Volatile, Pointer, Target, ProtectedTarget, DeducedFromActual,
+ OnlyIntrinsicInquiry)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
+ // PROTECTED_TARGET is not a procedure characteristic in the F'2028 draft
+ // (15.3.2.2).
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,7 +331,7 @@ using DummyArguments = std::vector<DummyArgument>;
// 15.3.3
struct FunctionResult {
- ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous)
+ ENUM_CLASS(Attr, Allocatable, Pointer, ProtectedTarget, Contiguous)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
DECLARE_CONSTRUCTORS_AND_ASSIGNMENTS(FunctionResult)
explicit FunctionResult(DynamicType);
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..d9a8f60333d48 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 draft R863
struct SaveStmt; // R856
struct TargetStmt; // R859
struct ValueStmt; // R861
@@ -372,7 +373,8 @@ 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 |
+// 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
@@ -386,9 +388,10 @@ struct OtherSpecificationStmt {
common::Indirection<IntentStmt>, common::Indirection<IntrinsicStmt>,
common::Indirection<NamelistStmt>, common::Indirection<OptionalStmt>,
common::Indirection<PointerStmt>, common::Indirection<ProtectedStmt>,
- common::Indirection<SaveStmt>, common::Indirection<TargetStmt>,
- common::Indirection<ValueStmt>, common::Indirection<VolatileStmt>,
- common::Indirection<CommonStmt>, common::Indirection<EquivalenceStmt>,
+ common::Indirection<ProtectedTargetStmt>, common::Indirection<SaveStmt>,
+ common::Indirection<TargetStmt>, common::Indirection<ValueStmt>,
+ common::Indirection<VolatileStmt>, common::Indirection<CommonStmt>,
+ common::Indirection<EquivalenceStmt>,
common::Indirection<BasedPointerStmt>,
common::Indirection<CUDAAttributesStmt>>
u;
@@ -995,9 +998,11 @@ struct ComponentArraySpec {
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// 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;
};
@@ -1616,6 +1623,10 @@ WRAPPER_CLASS(PointerStmt, std::list<PointerDecl>);
// R855 protected-stmt -> PROTECTED [::] entity-name-list
WRAPPER_CLASS(ProtectedStmt, std::list<Name>);
+// F'2028 draft 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..0a05bd1c885ac 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -178,6 +178,15 @@ 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 *FindNearestPointer(
+ const evaluate::DataRef &, bool skipRightmostSymbol = false);
+const Symbol *FindProtectedTargetPointer(
+ const evaluate::DataRef &, bool asPointer = false);
+const Symbol *FindProtectedTargetPointer(
+ const evaluate::Expr<evaluate::SomeType> &, bool asPointer = 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..197455adf1fe5 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -281,8 +281,15 @@ 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;
+ // PROTECTED_TARGET is not a procedure characteristic in the F'2028 draft.
+ Attrs attrsWithoutProtectedTarget{attrs};
+ Attrs thatAttrsWithoutProtectedTarget{that.attrs};
+ attrsWithoutProtectedTarget.reset(Attr::ProtectedTarget);
+ thatAttrsWithoutProtectedTarget.reset(Attr::ProtectedTarget);
+ return type == that.type &&
+ attrsWithoutProtectedTarget == thatAttrsWithoutProtectedTarget &&
+ intent == that.intent && coshape == that.coshape &&
+ cudaDataAttr == that.cudaDataAttr;
}
static bool IsOkWithSequenceAssociation(
@@ -373,6 +380,7 @@ bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
if (whyNot) {
*whyNot = "incompatible dummy data object attributes";
auto differences{attrs ^ actual.attrs};
+ differences.reset(DummyDataObject::Attr::ProtectedTarget);
auto sep{": "s};
differences.IterateOverMembers([&](DummyDataObject::Attr x) {
*whyNot += sep + std::string{EnumToString(x)};
@@ -440,6 +448,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 +1068,12 @@ 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;
+ Attrs attrsWithoutProtectedTarget{attrs};
+ Attrs thatAttrsWithoutProtectedTarget{that.attrs};
+ attrsWithoutProtectedTarget.reset(Attr::ProtectedTarget);
+ thatAttrsWithoutProtectedTarget.reset(Attr::ProtectedTarget);
+ return attrsWithoutProtectedTarget == thatAttrsWithoutProtectedTarget &&
+ cudaDataAttr == that.cudaDataAttr && u == that.u;
}
static std::optional<FunctionResult> CharacterizeFunctionResult(
@@ -1075,6 +1088,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 +1210,16 @@ static std::optional<std::string> AreIncompatibleFunctionResultShapes(
bool FunctionResult::IsCompatibleWith(
const FunctionResult &actual, std::string *whyNot) const {
+ // PROTECTED_TARGET is not a procedure characteristic in the F'2028 draft
+ // (15.3.3).
+ Attrs attrsWithoutProtectedTarget{attrs};
+ attrsWithoutProtectedTarget.reset(Attr::ProtectedTarget);
Attrs actualAttrs{actual.attrs};
+ actualAttrs.reset(Attr::ProtectedTarget);
if (!attrs.test(Attr::Contiguous)) {
actualAttrs.reset(Attr::Contiguous);
}
- if (attrs != actualAttrs) {
+ if (attrsWithoutProtectedTarget != 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..80c3d5a514922 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 |
+// 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>(protectedTargetAttr) ||
extension<LanguageFeature::CUDA>(
construct<ComponentAttrSpec>(Parser<CUDADataAttrSpec>{})) ||
construct<ComponentAttrSpec>(recovery(
@@ -742,7 +744,8 @@ TYPE_PARSER(
// CODIMENSION lbracket coarray-spec rbracket | CONTIGUOUS |
// DIMENSION ( array-spec ) | EXTERNAL | INTENT ( intent-spec ) |
// INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
-// PROTECTED | RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
+// PROTECTED | PROTECTED_TARGET |
+// RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
// VALUE | VOLATILE |
// CUDA-data-attr
TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
@@ -756,7 +759,8 @@ TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
construct<AttrSpec>(construct<Intrinsic>("INTRINSIC"_tok)) ||
construct<AttrSpec>(languageBindingSpec) || construct<AttrSpec>(optional) ||
construct<AttrSpec>(construct<Parameter>("PARAMETER"_tok)) ||
- construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedAttr) ||
+ construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedTargetAttr) ||
+ construct<AttrSpec>(protectedAttr) ||
construct<AttrSpec>("RANK" >>
construct<RankClause>(parenthesized(scalarIntConstantExpr))) ||
construct<AttrSpec>(save) ||
@@ -1050,6 +1054,11 @@ TYPE_PARSER(
TYPE_PARSER(
construct<ProtectedStmt>("PROTECTED" >> maybe("::"_tok) >> listOfNames))
+// F'2028 draft 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..adf32807ac3e2 100644
--- a/flang/lib/Parser/misc-parsers.h
+++ b/flang/lib/Parser/misc-parsers.h
@@ -49,6 +49,8 @@ constexpr auto allocatable{construct<Allocatable>("ALLOCATABLE"_tok)};
constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
+constexpr auto protectedTargetAttr{
+ construct<ProtectedTarget>("PROTECTED_TARGET"_tok)};
constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
constexpr auto save{construct<Save>("SAVE"_tok)};
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 08283a8be35e3..bd66efc35ac05 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -215,7 +215,8 @@ TYPE_CONTEXT_PARSER("specification construct"_en_US,
// access-stmt | allocatable-stmt | asynchronous-stmt | bind-stmt |
// codimension-stmt | contiguous-stmt | dimension-stmt | external-stmt |
// intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
-// pointer-stmt | protected-stmt | save-stmt | target-stmt |
+// pointer-stmt | protected-stmt | protected-target-stmt |
+// save-stmt | target-stmt |
// volatile-stmt | value-stmt | common-stmt | equivalence-stmt |
// (CUDA) CUDA-attributes-stmt
TYPE_PARSER(first(
@@ -232,6 +233,8 @@ TYPE_PARSER(first(
construct<OtherSpecificationStmt>(indirect(Parser<NamelistStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<OptionalStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<PointerStmt>{})),
+ // Keep PROTECTED_TARGET before PROTECTED to avoid keyword-prefix fallback.
+ 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..e3841ba24ab6c 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) { // F'2028 draft 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..70105f11f5898 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -510,6 +510,13 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
"Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
return false;
}
+ if (IsPointer(*ultimate_) && IsProtectedTarget(*ultimate_) &&
+ !allocateInfo_.gotSource) { // F'2028 draft C869
+ context.Say(name_.source,
+ "ALLOCATE of PROTECTED_TARGET pointer '%s' requires SOURCE="_err_en_US,
+ name_.source.ToString());
+ 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..2bd01f6ab9bc6 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -27,6 +27,27 @@ namespace characteristics = Fortran::evaluate::characteristics;
namespace Fortran::semantics {
+static bool HasProtectedTargetPointerActualArgument(
+ const SomeExpr &actual, bool asPointer = false) {
+ if (FindProtectedTargetPointer(actual, asPointer)) {
+ return true;
+ }
+ semantics::Attrs attrs{evaluate::GetAttrs(actual)};
+ return evaluate::IsObjectPointer(actual) && attrs.test(Attr::POINTER) &&
+ attrs.test(Attr::PROTECTED_TARGET);
+}
+
+static bool IsIntrinsicNullMoldArgument(
+ const evaluate::SpecificIntrinsic *intrinsic,
+ const characteristics::DummyArgument &dummyArg) {
+ if (!intrinsic || dummyArg.name != "mold") {
+ return false;
+ }
+ const auto &attrs{intrinsic->characteristics.value().attrs};
+ return attrs.test(characteristics::Procedure::Attr::NullPointer) ||
+ attrs.test(characteristics::Procedure::Attr::NullAllocatable);
+}
+
void CheckImplicitInterfaceArgKeywords(
const evaluate::ActualArgument &arg, parser::ContextualMessages &messages) {
auto restorer{
@@ -70,6 +91,17 @@ void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
+ const Symbol *protectedTarget{FindProtectedTargetPointer(*expr)};
+ if (protectedTarget || HasProtectedTargetPointerActualArgument(*expr)) {
+ if (auto *msg{messages.Say(
+ "Actual argument that is a PROTECTED_TARGET pointer or a subobject of one may not be passed to a procedure with an implicit interface"_err_en_US)}) {
+ if (protectedTarget) {
+ msg->Attach(protectedTarget->name(),
+ "PROTECTED_TARGET pointer '%s' declared here"_en_US,
+ protectedTarget->name());
+ }
+ }
+ }
if (IsBOZLiteral(*expr)) {
messages.Say("BOZ argument %s requires an explicit interface"_err_en_US,
expr->AsFortran());
@@ -454,6 +486,22 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
bool actualIsAssumedRank{IsAssumedRank(actual)};
bool actualIsPointer{evaluate::IsObjectPointer(actual)};
bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
+ const Symbol *actualProtectedTarget{
+ FindProtectedTargetPointer(actual, /*asPointer=*/false)};
+ const Symbol *actualProtectedTargetForPointerUse{
+ FindProtectedTargetPointer(actual, /*asPointer=*/true)};
+ bool actualHasProtectedTarget{actualProtectedTarget ||
+ HasProtectedTargetPointerActualArgument(actual, /*asPointer=*/false)};
+ bool actualHasProtectedTargetForPointerUse{
+ actualProtectedTargetForPointerUse ||
+ HasProtectedTargetPointerActualArgument(actual, /*asPointer=*/true)};
+ const bool emitProtectedTargetRules{scope != nullptr};
+ const bool isNullMoldArg{IsIntrinsicNullMoldArgument(intrinsic, dummyArg)};
+ // NULL's MOLD= and other intrinsic inquiry-only arguments are exempt from
+ // C872/C874: they are never defined and their association never changes.
+ const bool isIntrinsicInquiryOnly{isNullMoldArg ||
+ dummy.attrs.test(
+ characteristics::DummyDataObject::Attr::OnlyIntrinsicInquiry)};
bool actualMayBeAssumedSize{actualIsAssumedSize ||
(actualIsAssumedRank && !actualIsPointer && !actualIsAllocatable)};
bool actualIsPolymorphic{actualType.type().IsPolymorphic()};
@@ -826,6 +874,21 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
"ALLOCATABLE coarray '%s' may not be associated with INTENT(OUT) %s"_err_en_US,
actualLastSymbol->name(), dummyName);
}
+ bool emittedC874Error{false};
+ if (emitProtectedTargetRules && actualHasProtectedTarget && !dummyIsPointer &&
+ dummy.intent != common::Intent::In &&
+ !isIntrinsicInquiryOnly) { // F'2028 draft C874
+ if (auto *msg{messages.Say(
+ "Non-POINTER %s must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one"_err_en_US,
+ dummyName)}) {
+ if (actualProtectedTarget) {
+ msg->Attach(actualProtectedTarget->name(),
+ "PROTECTED_TARGET pointer '%s' declared here"_en_US,
+ actualProtectedTarget->name());
+ }
+ emittedC874Error = true;
+ }
+ }
// Definability checking
// Problems with polymorphism are caught in the callee's definition.
@@ -856,6 +919,11 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
if (isElemental) { // 15.5.2.4(21)
flags.set(DefinabilityFlag::VectorSubscriptIsOk);
}
+ if (emittedC874Error) {
+ // F'2028 draft C874 diagnoses this explicitly above; avoid duplicate
+ // F'2028 draft C866 "not definable" errors from the same root cause.
+ flags.set(DefinabilityFlag::IgnoreProtectedTarget);
+ }
if (actualIsPointer && dummyIsPointer) { // 19.6.8
flags.set(DefinabilityFlag::PointerDefinition);
}
@@ -1039,7 +1107,21 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// 15.5.2.7 -- dummy is POINTER
if (dummyIsPointer) {
- if (actualIsPointer || dummy.intent == common::Intent::In) {
+ bool missingDummyProtectedTarget{emitProtectedTargetRules &&
+ actualHasProtectedTargetForPointerUse && !isIntrinsicInquiryOnly &&
+ !dummy.attrs.test(characteristics::DummyDataObject::Attr::
+ ProtectedTarget)}; // F'2028 draft C872
+ if (missingDummyProtectedTarget) {
+ if (auto *msg{messages.Say(
+ "POINTER %s must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one"_err_en_US,
+ dummyName)}) {
+ if (actualProtectedTargetForPointerUse) {
+ msg->Attach(actualProtectedTargetForPointerUse->name(),
+ "PROTECTED_TARGET pointer '%s' declared here"_en_US,
+ actualProtectedTargetForPointerUse->name());
+ }
+ }
+ } else if (actualIsPointer || dummy.intent == common::Intent::In) {
if (scope) {
semantics::CheckPointerAssignment(context, messages.at(), dummyName,
dummy, actual, *scope,
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index c93b940aa69ed..58795923f27dc 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -68,6 +68,11 @@ 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 (IsPointer(*symbol) &&
+ IsProtectedTarget(*symbol)) { // F'2028 draft C868
+ context_.Say(source,
+ "PROTECTED_TARGET pointer '%s' may not be deallocated"_err_en_US,
+ name.source.ToString());
} else if (auto whyNot{
WhyNotDefinable(source, context_.FindScope(source),
{DefinabilityFlag::PointerDefinition,
@@ -108,6 +113,11 @@ 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 (IsPointer(*symbol) &&
+ IsProtectedTarget(*symbol)) { // F'2028 draft C868
+ context_.Say(source,
+ "PROTECTED_TARGET pointer '%s' may not be deallocated"_err_en_US,
+ source.ToString());
} 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..7c9108a7a08f9 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -347,6 +347,19 @@ void CheckHelper::Check(const Symbol &symbol) {
"A PROTECTED entity may not be in a common block"_err_en_US);
}
}
+ if (symbol.attrs().test(Attr::PROTECTED_TARGET)) {
+ // F'2028 draft C781 and C8109 cover components and the PROTECTED_TARGET
+ // statement. 8.5.16 describes the attribute only for data pointers, so a
+ // nonpointer with the attr-spec is rejected as well.
+ if (!evaluate::IsVariable(symbol) || !IsPointer(symbol)) {
+ messages_.Say(
+ "A PROTECTED_TARGET entity must be a data pointer"_err_en_US);
+ }
+ if (FindCommonBlockContaining(symbol)) { // F'2028 draft C867
+ messages_.Say(
+ "A pointer with the PROTECTED_TARGET attribute may not be in a common block"_err_en_US);
+ }
+ }
if (IsPointer(symbol)) {
CheckPointer(symbol);
}
@@ -1581,6 +1594,16 @@ class SubprogramMatchHelper {
}
return std::nullopt;
}
+ template <typename ATTRS> ATTRS FilterNonCharacteristicAttrs(ATTRS attrs) {
+ return attrs;
+ }
+ DummyDataObject::Attrs FilterNonCharacteristicAttrs(
+ DummyDataObject::Attrs attrs) {
+ // PROTECTED_TARGET is carried for F'2028 draft C872/C874 checking, but
+ // it is not a procedure characteristic in the F'2028 draft (15.3.2.2).
+ attrs.reset(DummyDataObject::Attr::ProtectedTarget);
+ return attrs;
+ }
std::string AsFortran(DummyDataObject::Attr attr) {
return parser::ToUpperCaseLetters(DummyDataObject::EnumToString(attr));
}
@@ -4234,6 +4257,8 @@ void SubprogramMatchHelper::Say(const Symbol &symbol1, const Symbol &symbol2,
template <typename ATTRS>
bool SubprogramMatchHelper::CheckSameAttrs(
const Symbol &symbol1, const Symbol &symbol2, ATTRS attrs1, ATTRS attrs2) {
+ attrs1 = FilterNonCharacteristicAttrs(attrs1);
+ attrs2 = FilterNonCharacteristicAttrs(attrs2);
if (attrs1 == attrs2) {
return true;
}
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index d6a654683001f..ef0be0f658278 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -94,6 +94,31 @@ static bool DefinesComponentPointerTarget(
}
}
+static std::optional<parser::Message> WhyNotDefinableViaProtectedTarget(
+ parser::CharBlock at, DefinabilityFlags flags,
+ const evaluate::DataRef &dataRef) {
+ if (flags.test(DefinabilityFlag::IgnoreProtectedTarget)) {
+ return std::nullopt;
+ }
+ if (const Symbol *definingPointer{FindNearestPointer(
+ dataRef, flags.test(DefinabilityFlag::PointerDefinition))};
+ definingPointer && IsProtectedTarget(definingPointer->GetUltimate())) {
+ const bool wholePointer{&definingPointer->GetUltimate() ==
+ &dataRef.GetLastSymbol().GetUltimate()};
+ parser::Message message{wholePointer
+ ? parser::Message{at,
+ "'%s' is a PROTECTED_TARGET pointer, so its target may not be defined through it"_en_US,
+ dataRef.GetLastSymbol().name()}
+ : parser::Message{at,
+ "'%s' may not be defined via PROTECTED_TARGET pointer '%s'"_en_US,
+ dataRef.GetLastSymbol().name(), definingPointer->name()}};
+ message.set_severity(parser::Severity::Error);
+ evaluate::AttachDeclaration(message, *definingPointer);
+ return message;
+ }
+ return std::nullopt;
+}
+
// Check the leftmost (or only) symbol from a data-ref or expression.
static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags, const Symbol &original,
@@ -102,6 +127,13 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
bool isPointerDefinition{flags.test(DefinabilityFlag::PointerDefinition)};
bool acceptAllocatable{flags.test(DefinabilityFlag::AcceptAllocatable)};
bool isTargetDefinition{!isPointerDefinition && IsPointer(ultimate)};
+ if (isTargetDefinition && IsProtectedTarget(ultimate) &&
+ !isComponentPointerTarget &&
+ !flags.test(DefinabilityFlag::IgnoreProtectedTarget)) {
+ return BlameSymbol(at,
+ "'%s' is a PROTECTED_TARGET pointer, so its target may not be defined through it"_en_US,
+ original);
+ }
if (const auto *association{ultimate.detailsIf<AssocEntityDetails>()}) {
if (!IsVariable(association->expr())) {
return BlameSymbol(at,
@@ -111,11 +143,31 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
"Construct association '%s' has a vector subscript"_en_US, original);
} else if (auto dataRef{evaluate::ExtractDataRef(
*association->expr(), true, true)}) {
+ DefinabilityFlags selectorFlags{flags};
+ selectorFlags.reset(DefinabilityFlag::PointerDefinition);
+ if (!isComponentPointerTarget) {
+ if (auto whyNotSelector{WhyNotDefinableViaProtectedTarget(
+ at, selectorFlags, *dataRef)}) {
+ return whyNotSelector;
+ }
+ }
return WhyNotDefinableBase(at, scope, flags, dataRef->GetFirstSymbol(),
isWholeSymbol &&
std::holds_alternative<evaluate::SymbolRef>(dataRef->u),
isComponentPointerTarget ||
DefinesComponentPointerTarget(*dataRef, flags));
+ } else if (!isComponentPointerTarget &&
+ evaluate::IsObjectPointer(association->expr().value()) &&
+ evaluate::GetAttrs(association->expr().value())
+ .test(Attr::PROTECTED_TARGET)) {
+ // Defining the associate name defines the target of the selector's
+ // PROTECTED_TARGET function result (F'2028 draft 8.5.16p2).
+ DefinabilityFlags selectorFlags{flags};
+ selectorFlags.reset(DefinabilityFlag::PointerDefinition);
+ if (auto whyNot{WhyNotDefinable(
+ at, scope, selectorFlags, *association->expr())}) {
+ return whyNot;
+ }
}
}
if (isTargetDefinition || isComponentPointerTarget) {
@@ -253,6 +305,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 (auto whyNotViaProtectedTarget{
+ WhyNotDefinableViaProtectedTarget(at, flags, dataRef)}) {
+ return whyNotViaProtectedTarget;
+ }
auto whyNotBase{
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
@@ -397,6 +453,15 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
if (auto whyNotDataRef{WhyNotDefinable(at, scope, flags, *dataRef)}) {
return whyNotDataRef;
}
+ } else if (!flags.test(DefinabilityFlag::PointerDefinition) &&
+ !flags.test(DefinabilityFlag::IgnoreProtectedTarget) &&
+ evaluate::IsObjectPointer(expr) &&
+ evaluate::GetAttrs(expr).test(Attr::PROTECTED_TARGET)) {
+ parser::Message message{at,
+ "'%s' may not be defined via PROTECTED_TARGET pointer function result"_en_US,
+ expr.AsFortran()};
+ message.set_severity(parser::Severity::Error);
+ return std::move(message);
} 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/definable.h b/flang/lib/Semantics/definable.h
index 816dad3c17fab..44877d48bc4b3 100644
--- a/flang/lib/Semantics/definable.h
+++ b/flang/lib/Semantics/definable.h
@@ -32,6 +32,7 @@ ENUM_CLASS(DefinabilityFlag,
AcceptAllocatable, // treat allocatable as if it were a pointer
SourcedAllocation, // ALLOCATE(a,SOURCE=)
PolymorphicOkInPure, // don't check for polymorphic type in pure subprogram
+ IgnoreProtectedTarget, // don't enforce PROTECTED_TARGET target-defn checks
DoNotNoteDefinition, // context does not imply definition
AllowEventLockOrNotifyType, PotentialDeallocation,
OnlyWarnOnImpureFinalInPureContext)
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..9935fb289188a 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -49,10 +49,12 @@ class PointerAssignmentChecker {
description_{"pointer '"s + lhs.name().ToString() + '\''}, lhs_{&lhs} {
set_lhsType(TypeAndShape::Characterize(lhs, foldingContext_));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
+ set_isProtectedTarget(lhs.attrs().test(Attr::PROTECTED_TARGET));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
}
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_isContiguous(bool);
+ PointerAssignmentChecker &set_isProtectedTarget(bool);
PointerAssignmentChecker &set_isVolatile(bool);
PointerAssignmentChecker &set_isBoundsRemapping(bool);
PointerAssignmentChecker &set_isAssumedRank(bool);
@@ -91,6 +93,7 @@ class PointerAssignmentChecker {
std::optional<Procedure> procedure_;
bool characterizedProcedure_{false};
bool isContiguous_{false};
+ bool isLHSProtectedTarget_{false};
bool isVolatile_{false};
bool isBoundsRemapping_{false};
bool isAssumedRank_{false};
@@ -111,6 +114,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isContiguous(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isProtectedTarget(
+ bool isProtectedTarget) {
+ isLHSProtectedTarget_ = isProtectedTarget;
+ return *this;
+}
+
PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
bool isVolatile) {
isVolatile_ = isVolatile;
@@ -229,6 +238,29 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
}
}
}
+ if (const Symbol *protectedTarget{FindProtectedTargetPointer(rhs)}) {
+ // The nearest pointer rule from F'2023 9.4.2p5 is shared with
+ // F'2028 draft C870-C874 and F'2028 draft 8.5.16p2.
+ if (!isLHSProtectedTarget_) {
+ if (pointerComponentLHS_) { // F'2028 draft C871
+ if (auto *msg{Say(
+ "Structure constructor component '%s' must have the PROTECTED_TARGET attribute when its pointer target is a PROTECTED_TARGET pointer or a subobject of one"_err_en_US,
+ pointerComponentLHS_->name())}) {
+ msg->Attach(protectedTarget->name(),
+ "PROTECTED_TARGET pointer '%s' declared here"_en_US,
+ protectedTarget->name());
+ }
+ } else { // F'2028 draft C870
+ if (auto *msg{Say(
+ "Pointer assignment target is a PROTECTED_TARGET pointer or a subobject of one; the left-hand side pointer must also have the PROTECTED_TARGET attribute"_err_en_US)}) {
+ msg->Attach(protectedTarget->name(),
+ "PROTECTED_TARGET pointer '%s' declared here"_en_US,
+ protectedTarget->name());
+ }
+ }
+ return false;
+ }
+ }
if (isContiguous_) {
if (auto contiguous{evaluate::IsContiguous(rhs, foldingContext_)}) {
if (!*contiguous) {
@@ -243,13 +275,20 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
"Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
}
}
- // Warn about undefinable data targets
- if (auto because{
- WhyNotDefinable(foldingContext_.messages().at(), scope_, {}, rhs)}) {
- if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
- "Pointer target is not a definable variable"_warn_en_US)}) {
- msg->Attach(std::move(because->set_severity(parser::Severity::Because)));
- return false;
+ // A PROTECTED_TARGET pointer cannot define its target, so associating it
+ // with an undefinable target is not diagnosed. In the F'2028 draft this
+ // follows 8.5.16 NOTE 1 (p => x with a use-associated PROTECTED x), which
+ // conflicts with F'2028 draft C864; ordinary pointers keep the optional
+ // warning.
+ if (!isLHSProtectedTarget_) {
+ 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;
@@ -288,6 +327,15 @@ bool PointerAssignmentChecker::Check(const evaluate::FunctionRef<T> &f) {
} else if (!funcResult->attrs.test(FunctionResult::Attr::Pointer)) {
msg =
"%s is associated with the result of a reference to function '%s' that is not a pointer"_err_en_US;
+ } else if (funcResult->attrs.test(FunctionResult::Attr::ProtectedTarget) &&
+ !isLHSProtectedTarget_) {
+ if (pointerComponentLHS_) { // F'2028 draft C871
+ Say("Structure constructor component '%s' must have the PROTECTED_TARGET attribute when its pointer target is a PROTECTED_TARGET pointer or a subobject of one"_err_en_US,
+ pointerComponentLHS_->name());
+ } else { // F'2028 draft C870
+ Say("Pointer assignment target is a PROTECTED_TARGET pointer or a subobject of one; the left-hand side pointer must also have the PROTECTED_TARGET attribute"_err_en_US);
+ }
+ return false;
} else if (isContiguous_ &&
!funcResult->attrs.test(FunctionResult::Attr::Contiguous)) {
auto restorer{common::ScopedSet(lhs_, symbol)};
@@ -618,6 +666,8 @@ bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
return PointerAssignmentChecker{context, scope, source, description}
.set_lhsType(common::Clone(lhs.type))
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
+ .set_isProtectedTarget(
+ lhs.attrs.test(DummyDataObject::Attr::ProtectedTarget))
.set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
.set_isAssumedRank(isAssumedRank)
.set_isRHSPointerActualArgument(isPointerActualArgument)
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 3571a1de521f7..5d4c64aa7e07e 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);
@@ -6873,7 +6878,8 @@ Symbol &DeclarationVisitor::DeclareUnknownEntity(
ConvertToProcEntity(symbol);
} else if (symbol.attrs().HasAny(Attrs{Attr::ALLOCATABLE,
Attr::ASYNCHRONOUS, Attr::CONTIGUOUS, Attr::PARAMETER,
- Attr::SAVE, Attr::TARGET, Attr::VALUE, Attr::VOLATILE})) {
+ Attr::PROTECTED_TARGET, Attr::SAVE, Attr::TARGET,
+ Attr::VALUE, Attr::VOLATILE})) {
ConvertToObjectEntity(symbol);
}
if (attrs.test(Attr::BIND_C)) {
@@ -9346,7 +9352,9 @@ 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};
+ // F'2028 draft 11.1.12.3p2: exactly the same attributes as selector.
+ 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..e68c8dc18aeea 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"
@@ -327,6 +328,62 @@ bool IsPointerDummy(const Symbol &symbol) {
return IsPointer(symbol) && IsDummy(symbol);
}
+const Symbol *FindNearestPointer(
+ const evaluate::DataRef &dataRef, bool skipRightmostSymbol) {
+ // Returns the nearest (rightmost) pointer part in a designator.
+ // skipRightmostSymbol=true skips that rightmost pointer symbol and returns
+ // the next pointer above it, if any.
+ if (!skipRightmostSymbol) {
+ return evaluate::GetLastPointerSymbol(dataRef);
+ }
+ return common::visit(
+ common::visitors{
+ [](const evaluate::SymbolRef &) -> const Symbol * { return nullptr; },
+ [](const evaluate::Component &component) -> const Symbol * {
+ return evaluate::GetLastPointerSymbol(component.base());
+ },
+ [](const evaluate::ArrayRef &) -> const Symbol * {
+ // The rightmost part is an element/section, not a pointer.
+ return nullptr;
+ },
+ [](const evaluate::CoarrayRef &) -> const Symbol * {
+ return nullptr;
+ },
+ },
+ dataRef.u);
+}
+
+const Symbol *FindProtectedTargetPointer(
+ const evaluate::DataRef &dataRef, bool asPointer) {
+ // F'2028 draft C870-C874 says "or a subobject thereof".
+ // We read that as a part of the pointer target with no pointer in between,
+ // as in F'2023 9.4.2p5.
+ // F'2028 draft C870/C871/C873/C874 check the nearest pointer.
+ // F'2028 draft C872 also checks above a rightmost pointer component.
+ if (const Symbol *pointer{
+ FindNearestPointer(dataRef, /*skipRightmostSymbol=*/false)};
+ pointer && IsProtectedTarget(pointer->GetUltimate())) {
+ return pointer;
+ }
+ if (asPointer) {
+ if (const Symbol *pointerAboveRightmost{
+ FindNearestPointer(dataRef, /*skipRightmostSymbol=*/true)};
+ pointerAboveRightmost &&
+ IsProtectedTarget(pointerAboveRightmost->GetUltimate())) {
+ return pointerAboveRightmost;
+ }
+ }
+ return nullptr;
+}
+
+const Symbol *FindProtectedTargetPointer(
+ const evaluate::Expr<evaluate::SomeType> &expr, bool asPointer) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
+ return FindProtectedTargetPointer(*dataRef, asPointer);
+ }
+ return nullptr;
+}
+
bool IsBindCProcedure(const Symbol &original) {
const Symbol &symbol{original.GetUltimate()};
if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
diff --git a/flang/test/Parser/protected-target.f90 b/flang/test/Parser/protected-target.f90
new file mode 100644
index 0000000000000..6c7fd3f511364
--- /dev/null
+++ b/flang/test/Parser/protected-target.f90
@@ -0,0 +1,29 @@
+! Test PROTECTED_TARGET parsing and unparsing.
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s
+
+subroutine stmt_forms(p, q)
+ integer, pointer :: p
+ integer, pointer, protected_target :: q
+ protected_target p
+ protected_target :: q
+ protected :: p
+end
+
+module m
+ type t
+ integer, pointer, protected_target :: c
+ end type
+end module
+
+! CHECK: SUBROUTINE stmt_forms
+! CHECK: INTEGER, POINTER :: p
+! CHECK: INTEGER, POINTER, PROTECTED_TARGET :: q
+! CHECK: PROTECTED_TARGET :: p
+! CHECK: PROTECTED_TARGET :: q
+! CHECK: PROTECTED :: p
+! CHECK: END SUBROUTINE
+! CHECK: MODULE m
+! CHECK: TYPE :: t
+! CHECK: INTEGER, POINTER, PROTECTED_TARGET :: c
+! CHECK: END TYPE
+! CHECK: END MODULE
diff --git a/flang/test/Semantics/modfile-protected-target.f90 b/flang/test/Semantics/modfile-protected-target.f90
new file mode 100644
index 0000000000000..cbc0d5b12cf4c
--- /dev/null
+++ b/flang/test/Semantics/modfile-protected-target.f90
@@ -0,0 +1,47 @@
+! RUN: %python %S/test_modfile.py %s %flang_fc1
+
+module modfile_protected_target
+ implicit none
+ integer, target, save :: x = 1
+ integer, pointer, protected_target, save :: p => x
+ type holder
+ integer, pointer, protected_target :: c => x
+ end type
+contains
+ subroutine takes_plain(a)
+ integer, pointer :: a
+ end
+ subroutine takes_pt(a)
+ integer, pointer, protected_target :: a
+ end
+ function plain_result() result(r)
+ integer, pointer :: r
+ r => x
+ end
+ function pt_result() result(r)
+ integer, pointer, protected_target :: r
+ r => x
+ end
+end module
+
+!Expect: modfile_protected_target.mod
+!module modfile_protected_target
+!integer(4),save,target::x
+!integer(4),pointer,protected_target,save::p
+!type::holder
+!integer(4),pointer,protected_target::c=>x
+!end type
+!contains
+!subroutine takes_plain(a)
+!integer(4),pointer::a
+!end
+!subroutine takes_pt(a)
+!integer(4),pointer,protected_target::a
+!end
+!function plain_result() result(r)
+!integer(4),pointer::r
+!end
+!function pt_result() result(r)
+!integer(4),pointer,protected_target::r
+!end
+!end
diff --git a/flang/test/Semantics/protected-target-characteristics.f90 b/flang/test/Semantics/protected-target-characteristics.f90
new file mode 100644
index 0000000000000..315137afcca3b
--- /dev/null
+++ b/flang/test/Semantics/protected-target-characteristics.f90
@@ -0,0 +1,131 @@
+! RUN: %flang_fc1 -fsyntax-only -Wproc-dummy-arg-shapes -Werror %s
+
+module pt_chars
+ interface
+ module subroutine sep_iface_pt(a)
+ integer, pointer, protected_target :: a
+ end
+ module subroutine sep_iface_plain(a)
+ integer, pointer :: a
+ end
+ module function sep_iface_pt_result() result(r)
+ integer, pointer, protected_target :: r
+ end
+ module function sep_iface_plain_result() result(r)
+ integer, pointer :: r
+ end
+ end interface
+contains
+ function plain_result() result(r)
+ integer, target, save :: x = 1
+ integer, pointer :: r
+ r => x
+ end
+
+ function protected_result() result(r)
+ integer, target, save :: x = 1
+ integer, pointer, protected_target :: r
+ r => x
+ end
+
+ subroutine plain_dummy(a)
+ integer, pointer :: a
+ a = 99
+ end
+
+ subroutine protected_dummy(a)
+ integer, pointer, protected_target :: a
+ end
+
+ subroutine takes_proc_result(proc)
+ interface
+ function iface_pt_result() result(r)
+ integer, pointer, protected_target :: r
+ end
+ end interface
+ procedure(iface_pt_result) :: proc
+ end
+
+ subroutine takes_proc_plain_result(proc)
+ interface
+ function iface_plain_result() result(r)
+ integer, pointer :: r
+ end
+ end interface
+ procedure(iface_plain_result) :: proc
+ end
+
+ subroutine takes_proc_dummy(proc)
+ interface
+ subroutine iface_pt_dummy(a)
+ integer, pointer, protected_target :: a
+ end
+ end interface
+ procedure(iface_pt_dummy) :: proc
+ end
+
+ subroutine takes_proc_plain_dummy(proc)
+ interface
+ subroutine iface_plain_dummy(a)
+ integer, pointer :: a
+ end
+ end interface
+ procedure(iface_plain_dummy) :: proc
+ end
+
+ subroutine test
+ abstract interface
+ function iface_pt_result() result(r)
+ integer, pointer, protected_target :: r
+ end
+ function iface_plain_result() result(r)
+ integer, pointer :: r
+ end
+ subroutine iface_pt_dummy(a)
+ integer, pointer, protected_target :: a
+ end
+ subroutine iface_plain_dummy(a)
+ integer, pointer :: a
+ end
+ end interface
+ procedure(iface_pt_result), pointer :: pfr_pt
+ procedure(iface_plain_result), pointer :: pfr_plain
+ procedure(iface_pt_dummy), pointer :: ppd_pt
+ procedure(iface_plain_dummy), pointer :: ppd_plain
+ pfr_pt => plain_result
+ pfr_plain => protected_result
+ ppd_pt => plain_dummy
+ ppd_plain => protected_dummy
+ call takes_proc_result(plain_result)
+ call takes_proc_result(protected_result)
+ call takes_proc_plain_result(plain_result)
+ call takes_proc_plain_result(protected_result)
+ call takes_proc_dummy(plain_dummy)
+ call takes_proc_dummy(protected_dummy)
+ call takes_proc_plain_dummy(plain_dummy)
+ call takes_proc_plain_dummy(protected_dummy)
+ end
+end
+
+submodule(pt_chars) pt_chars_sub
+contains
+ module subroutine sep_iface_pt(a)
+ integer, pointer :: a
+ end
+
+ module subroutine sep_iface_plain(a)
+ integer, pointer, protected_target :: a
+ end
+
+ module function sep_iface_pt_result() result(r)
+ integer, pointer :: r
+ integer, target, save :: x = 1
+ r => x
+ end
+
+ module function sep_iface_plain_result() result(r)
+ integer, pointer, protected_target :: r
+ integer, target, save :: x = 1
+ r => x
+ end
+end
diff --git a/flang/test/Semantics/protected-target-conflict.f90 b/flang/test/Semantics/protected-target-conflict.f90
new file mode 100644
index 0000000000000..d94a15063641d
--- /dev/null
+++ b/flang/test/Semantics/protected-target-conflict.f90
@@ -0,0 +1,40 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Wpointer-to-undefinable -Werror
+
+! This captures the current working-draft conflict between 8.5.15 C864 and
+! 8.5.16 NOTE 1. Flang accepts association through a PROTECTED_TARGET pointer
+! by default; the optional warning remains for ordinary pointers.
+
+module m_conflict
+ implicit none
+ integer, target, protected :: x = 1
+end module
+
+module m_conflict_use
+ use m_conflict
+ implicit none
+ type t
+ integer, pointer, protected_target :: c => x
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ integer, pointer :: d => x
+ end type
+ integer, pointer, protected_target :: init_pt => x
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ integer, pointer :: init_plain => x
+contains
+ subroutine outside
+ type(t) :: o
+ integer, pointer, protected_target :: p
+ integer, pointer :: q
+ p => x
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ q => x
+ o%c => x
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ o%d => x
+ o = t(x, null())
+ end
+end module
diff --git a/flang/test/Semantics/protected-target-function-result.f90 b/flang/test/Semantics/protected-target-function-result.f90
new file mode 100644
index 0000000000000..ff6b047469e32
--- /dev/null
+++ b/flang/test/Semantics/protected-target-function-result.f90
@@ -0,0 +1,48 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+module protected_target_function_result
+ integer, target, save :: x = 1
+ integer, target, save :: y(2) = [1, 2]
+contains
+ function f() result(r)
+ integer, pointer, protected_target :: r
+ r => x
+ end
+ function g() result(r)
+ class(*), pointer, protected_target :: r(:)
+ r => y
+ end
+ subroutine s2(d)
+ integer, intent(inout) :: d
+ end
+ subroutine t
+ type box
+ integer, pointer :: p
+ end type
+ type(box) :: h
+ integer, pointer :: q
+ integer, pointer, protected_target :: pq
+ external ext
+ !ERROR: Pointer assignment target is a PROTECTED_TARGET pointer or a subobject of one; the left-hand side pointer must also have the PROTECTED_TARGET attribute
+ q => f()
+ pq => f()
+ !ERROR: Structure constructor component 'p' must have the PROTECTED_TARGET attribute when its pointer target is a PROTECTED_TARGET pointer or a subobject of one
+ h = box(f())
+ !ERROR: Actual argument that is a PROTECTED_TARGET pointer or a subobject of one may not be passed to a procedure with an implicit interface
+ call ext(f())
+ !ERROR: Non-POINTER dummy argument 'd=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call s2(f())
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'f()' may not be defined via PROTECTED_TARGET pointer function result
+ f() = 3
+ select type (a => g())
+ type is (integer)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'g()' may not be defined via PROTECTED_TARGET pointer function result
+ a(1) = 4
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'd=' is not definable
+ !BECAUSE: 'g()' may not be defined via PROTECTED_TARGET pointer function result
+ call s2(a(1))
+ end select
+ end
+end
diff --git a/flang/test/Semantics/protected-target-modfile-use.f90 b/flang/test/Semantics/protected-target-modfile-use.f90
new file mode 100644
index 0000000000000..ba6915726075b
--- /dev/null
+++ b/flang/test/Semantics/protected-target-modfile-use.f90
@@ -0,0 +1,61 @@
+! RUN: split-file %s %t
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/mod.f90
+! RUN: %python %S/test_errors.py %t/use.f90 %flang_fc1 -I%t
+
+!--- mod.f90
+module modfile_protected_target_use
+ implicit none
+ integer, target, save :: x = 1
+ integer, pointer, protected_target, save :: p => x
+ type holder
+ integer, pointer, protected_target :: c => x
+ end type
+contains
+ subroutine takes_plain(a)
+ integer, pointer :: a
+ end
+ subroutine takes_pt(a)
+ integer, pointer, protected_target :: a
+ end
+ subroutine takes_no_intent(a)
+ integer :: a
+ end
+ function plain_result() result(r)
+ integer, pointer :: r
+ r => x
+ end
+ function pt_result() result(r)
+ integer, pointer, protected_target :: r
+ r => x
+ end
+end module
+
+!--- use.f90
+subroutine use_it
+ use modfile_protected_target_use
+ implicit none
+ procedure(plain_result), pointer :: pp
+ procedure(pt_result), pointer :: qq
+ type(holder) :: obj
+ integer, pointer :: q
+ call takes_pt(p)
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call takes_plain(p)
+ qq => pt_result
+ pp => pt_result
+ !ERROR: Pointer assignment target is a PROTECTED_TARGET pointer or a subobject of one; the left-hand side pointer must also have the PROTECTED_TARGET attribute
+ q => obj%c
+ !ERROR: Non-POINTER dummy argument 'a=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call takes_no_intent(obj%c)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ p = 2
+end
+
+subroutine use_rename
+ use modfile_protected_target_use, only: rp => p
+ implicit none
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'rp' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ rp = 3
+end
diff --git a/flang/test/Semantics/protected-target-override.f90 b/flang/test/Semantics/protected-target-override.f90
new file mode 100644
index 0000000000000..7389c9e663297
--- /dev/null
+++ b/flang/test/Semantics/protected-target-override.f90
@@ -0,0 +1,31 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+module protected_target_override
+ type base
+ contains
+ procedure :: s => bs
+ end type
+ type, extends(base) :: ext
+ contains
+ procedure :: s => es
+ end type
+ !ERROR: Generic 'g' may not have specific procedures 'g1' and 'g2' as their interfaces are not distinguishable
+ interface g
+ module procedure g1, g2
+ end interface
+contains
+ subroutine bs(this, a)
+ class(base) :: this
+ integer, pointer, protected_target :: a
+ end
+ subroutine es(this, a)
+ class(ext) :: this
+ integer, pointer :: a
+ end
+ subroutine g1(a)
+ integer, pointer, protected_target :: a
+ end
+ subroutine g2(a)
+ integer, pointer :: a
+ end
+end
diff --git a/flang/test/Semantics/protected-target.f90 b/flang/test/Semantics/protected-target.f90
new file mode 100644
index 0000000000000..65c46608de583
--- /dev/null
+++ b/flang/test/Semantics/protected-target.f90
@@ -0,0 +1,566 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+subroutine c8109_stmt()
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ integer :: i
+ protected_target :: i
+end
+
+subroutine attr_spec_nonpointer()
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ integer, protected_target :: i
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ integer, allocatable, protected_target :: a(:)
+end
+
+subroutine c781_component()
+ type t
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ integer, protected_target :: c
+ end type
+end
+
+subroutine c867_common()
+ !ERROR: A pointer with the PROTECTED_TARGET attribute may not be in a common block
+ integer, pointer, protected_target :: p
+ common /blk/ p
+end
+
+subroutine c869_allocate()
+ integer, pointer, protected_target :: p
+ !ERROR: ALLOCATE of PROTECTED_TARGET pointer 'p' requires SOURCE=
+ allocate(p)
+ !ERROR: ALLOCATE of PROTECTED_TARGET pointer 'p' requires SOURCE=
+ allocate(p, mold=1)
+end
+
+subroutine c868_deallocate()
+ integer, pointer, protected_target :: p
+ allocate(p, source=1)
+ !ERROR: PROTECTED_TARGET pointer 'p' may not be deallocated
+ deallocate(p)
+end
+
+subroutine c866_define()
+ integer, target :: x = 1
+ integer, pointer, protected_target :: p
+ p => x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ p = 2
+end
+
+subroutine c870_drop()
+ integer, target :: x = 1
+ integer, pointer, protected_target :: p
+ integer, pointer :: q
+ p => x
+ !ERROR: Pointer assignment target is a PROTECTED_TARGET pointer or a subobject of one; the left-hand side pointer must also have the PROTECTED_TARGET attribute
+ q => p
+end
+
+subroutine c871_constructor()
+ type t
+ integer, pointer :: q
+ end type
+ type(t) :: a
+ integer, target :: x = 1
+ integer, pointer, protected_target :: p
+ p => x
+ !ERROR: Structure constructor component 'q' must have the PROTECTED_TARGET attribute when its pointer target is a PROTECTED_TARGET pointer or a subobject of one
+ a = t(p)
+end
+
+subroutine c872_and_c874_calls()
+ interface
+ subroutine takes_plain_ptr(a)
+ integer, pointer :: a
+ end
+ subroutine takes_pt_ptr(a)
+ integer, pointer, protected_target :: a
+ end
+ subroutine takes_no_intent(a)
+ integer :: a
+ end
+ subroutine takes_value(a)
+ integer, value :: a
+ end
+ subroutine takes_value_in(a)
+ integer, value, intent(in) :: a
+ end
+ subroutine takes_in(a)
+ integer, intent(in) :: a
+ end
+ end interface
+ integer, target :: x = 1
+ integer, pointer, protected_target :: p
+ integer, pointer :: q
+ p => x
+ q => x
+ call takes_pt_ptr(q)
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call takes_plain_ptr(p)
+ !ERROR: Non-POINTER dummy argument 'a=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call takes_no_intent(p)
+ !ERROR: Non-POINTER dummy argument 'a=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call takes_value(p)
+ call takes_value_in(p)
+ call takes_in(p)
+end
+
+subroutine c874_defined_assignment_duplicate()
+ type t
+ integer :: x = 0
+ end type
+ interface assignment(=)
+ procedure :: set_t
+ end interface
+ type(t), target :: obj
+ type(t), pointer, protected_target :: p
+ p => obj
+ ! Keep both errors: C874 for the call and 8.5.16p2 for assignment.
+ !ERROR: Non-POINTER dummy argument 'lhs=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ p = 1
+contains
+ subroutine set_t(lhs, rhs)
+ type(t), intent(inout) :: lhs
+ integer, intent(in) :: rhs
+ lhs%x = rhs
+ end
+end
+
+subroutine c872_subobject_section()
+ interface
+ subroutine pin(a)
+ integer, pointer, intent(in) :: a
+ end
+ subroutine pinv(a)
+ integer, pointer, intent(in) :: a(:)
+ end
+ subroutine takes_in(a)
+ integer, intent(in) :: a
+ end
+ end interface
+ type t
+ integer, pointer :: q(:)
+ end type
+ type(t), target :: n
+ type(t) :: o
+ integer, target :: x(4) = [1, 2, 3, 4]
+ integer, pointer, protected_target :: pv(:)
+ type(t), pointer, protected_target :: p
+ integer, pointer :: q(:)
+ pv => x
+ n%q => x
+ p => n
+ !ERROR: Pointer assignment target is a PROTECTED_TARGET pointer or a subobject of one; the left-hand side pointer must also have the PROTECTED_TARGET attribute
+ q => pv(1:2)
+ !ERROR: Structure constructor component 'q' must have the PROTECTED_TARGET attribute when its pointer target is a PROTECTED_TARGET pointer or a subobject of one
+ o = t(pv(1:2))
+ call takes_in(pv(2))
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call pinv(pv(1:2))
+ call pin(p%q(1))
+ call pinv(p%q(1:2))
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call pinv(p%q)
+end
+
+subroutine c873_implicit()
+ integer, target :: x = 1
+ integer, pointer, protected_target :: p
+ external ext
+ p => x
+ !ERROR: Actual argument that is a PROTECTED_TARGET pointer or a subobject of one may not be passed to a procedure with an implicit interface
+ call ext(p)
+end
+
+subroutine c873_subobject_implicit()
+ integer, target :: x(2) = [1, 2]
+ integer, pointer, protected_target :: p(:)
+ external ext
+ p => x
+ !ERROR: Actual argument that is a PROTECTED_TARGET pointer or a subobject of one may not be passed to a procedure with an implicit interface
+ call ext(p(1))
+end
+
+subroutine c874_null_mold()
+ integer, pointer, protected_target :: p(:), q(:)
+ p => null(mold=q)
+ q => null(mold=p)
+end
+
+subroutine c868_c869_components()
+ type t
+ integer, pointer, protected_target :: c
+ end type
+ type(t) :: x
+ !ERROR: ALLOCATE of PROTECTED_TARGET pointer 'c' requires SOURCE=
+ allocate(x%c)
+ allocate(x%c, source=1)
+ !ERROR: PROTECTED_TARGET pointer 'c' may not be deallocated
+ deallocate(x%c)
+end
+
+subroutine c866_subcomponents()
+ type t
+ integer, pointer :: q
+ integer, allocatable :: a
+ end type
+ type holder
+ integer, pointer :: q
+ end type
+ interface
+ subroutine takes_inout(a)
+ integer, intent(inout) :: a
+ end
+ subroutine noint(a)
+ integer, pointer :: a
+ end
+ end interface
+ type(t), pointer, protected_target :: p
+ type(holder) :: h
+ integer, target :: y
+ integer, pointer :: r
+ external ext
+ p%q = 1
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'q' may not be defined via PROTECTED_TARGET pointer 'p'
+ p%q => y
+ r => p%q
+ h = holder(p%q)
+ !ERROR: 'q' may not appear in NULLIFY
+ !BECAUSE: 'q' may not be defined via PROTECTED_TARGET pointer 'p'
+ nullify(p%q)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'q' may not be defined via PROTECTED_TARGET pointer 'p'
+ allocate(p%q)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'a' may not be defined via PROTECTED_TARGET pointer 'p'
+ allocate(p%a)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'a' may not be defined via PROTECTED_TARGET pointer 'p'
+ p%a = 1
+ call takes_inout(p%q)
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call noint(p%q)
+ call ext(p%q)
+end
+
+subroutine c870_to_c874_nearest_pointer()
+ type leaf
+ integer :: c
+ end type
+ type t
+ type(leaf), pointer :: q
+ integer :: c
+ end type
+ type holder
+ integer, pointer :: p
+ end type
+ interface
+ subroutine inout(x)
+ integer, intent(inout) :: x
+ end
+ end interface
+ type(t), pointer, protected_target :: p
+ type(holder) :: h
+ integer, pointer :: w
+ external ext
+ w => p%q%c
+ call inout(p%q%c)
+ h = holder(p%q%c)
+ call ext(p%q%c)
+ !ERROR: Pointer assignment target is a PROTECTED_TARGET pointer or a subobject of one; the left-hand side pointer must also have the PROTECTED_TARGET attribute
+ w => p%c
+ !ERROR: Non-POINTER dummy argument 'x=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call inout(p%c)
+ !ERROR: Structure constructor component 'p' must have the PROTECTED_TARGET attribute when its pointer target is a PROTECTED_TARGET pointer or a subobject of one
+ h = holder(p%c)
+ !ERROR: Actual argument that is a PROTECTED_TARGET pointer or a subobject of one may not be passed to a procedure with an implicit interface
+ call ext(p%c)
+end
+
+subroutine c866_associate()
+ interface
+ subroutine takes_no_intent_vec(a)
+ integer :: a(:)
+ end
+ end interface
+ integer, target :: x(2) = [1, 2]
+ integer, pointer, protected_target :: p(:)
+ integer, pointer :: q(:)
+ p => x
+ associate (a => p)
+ ! 'a' does not have PROTECTED_TARGET (F'2028 draft 11.1.3.3), so 'q => a' is accepted.
+ q => a
+ call takes_no_intent_vec(a(1:1))
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ a(1) = 1
+ end associate
+end
+
+subroutine c866_associate_pointer_component_selectors()
+ type node
+ integer, pointer :: q => null()
+ integer :: c = 0
+ end type
+ type(node), target :: n, n2
+ type(node), pointer, protected_target :: np
+ integer, target :: y = 1
+ n%q => y
+ np => n
+ np%q = 1
+ associate (a => np)
+ a%q = 2
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'np' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ a%q => y
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'np' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ a = n2
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'np' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ a%c = 3
+ end associate
+end
+
+subroutine c866_associate_component_selectors()
+ type t
+ integer, pointer, protected_target :: c => null()
+ integer, pointer, protected_target :: v(:) => null()
+ class(*), pointer, protected_target :: u => null()
+ end type
+ type plain
+ integer, pointer :: c => null()
+ end type
+ type inner
+ integer :: c = 0
+ end type
+ type holder
+ type(inner), pointer, protected_target :: p => null()
+ end type
+ interface
+ subroutine takes_inout(x)
+ integer, intent(inout) :: x
+ end
+ end interface
+ type(t) :: o
+ type(plain) :: ok
+ type(holder) :: h
+ integer, target :: y = 1, w(2) = [1, 2]
+ type(inner), target :: n
+ integer, pointer :: q
+ o%c => y
+ o%v => w
+ o%u => y
+ ok%c => y
+ h%p => n
+ associate (a => ok%c)
+ q => a
+ end associate
+ associate (a => o%c)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'c' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ a = 2
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'c' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ call takes_inout(a)
+ end associate
+ associate (b => o%v(1:2))
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'v' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ b(1) = 3
+ end associate
+ select type (z => o%u)
+ type is (integer)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'u' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ z = 4
+ end select
+ associate (c => h%p%c)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'c' may not be defined via PROTECTED_TARGET pointer 'p'
+ c = 5
+ end associate
+end
+
+subroutine c866_select_type_pointer_component_selector()
+ type node
+ integer, pointer :: q => null()
+ end type
+ interface
+ subroutine takes_inout(v)
+ integer, intent(inout) :: v
+ end
+ end interface
+ type(node), target :: n
+ class(node), pointer, protected_target :: cp
+ integer, target :: y = 1
+ n%q => y
+ cp => n
+ select type (c => cp)
+ type is (node)
+ c%q = 4
+ call takes_inout(c%q)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'cp' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ c%q => y
+ end select
+end
+
+subroutine c866_associate_pointer_function_selector()
+ type node
+ integer, pointer :: w => null()
+ integer, allocatable :: a
+ end type
+ interface
+ subroutine takes_inout(v)
+ integer, intent(inout) :: v
+ end
+ end interface
+ type(node), target :: n
+ integer, target :: y = 1
+ associate (a => plain_result())
+ a%w => y
+ nullify(a%w)
+ allocate(a%w)
+ deallocate(a%w)
+ a%a = 1
+ end associate
+ associate (b => protected_result())
+ b%w = 2
+ call takes_inout(b%w)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'protected_result()' may not be defined via PROTECTED_TARGET pointer function result
+ b%w => y
+ end associate
+contains
+ function plain_result() result(r)
+ type(node), pointer :: r
+ r => n
+ end
+ function protected_result() result(r)
+ type(node), pointer, protected_target :: r
+ r => n
+ end
+end
+
+subroutine c872_c874_intrinsics()
+ use iso_c_binding
+ integer, target :: x(2) = [1, 2]
+ integer, pointer, protected_target :: p(:)
+ integer, pointer, protected_target :: ps(:)
+ real, pointer, protected_target :: r(:)
+ type(c_ptr) :: cptr
+ logical :: l
+ integer :: n
+ p => x
+ l = associated(p)
+ l = associated(p, p)
+ n = size(p) + lbound(p, 1) + ubound(p, 1)
+ ps => null(mold=p)
+ cptr = c_loc(x(1))
+ !ERROR: POINTER dummy argument 'fptr=' must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call c_f_pointer(cptr, ps, [2])
+ !ERROR: Non-POINTER dummy argument 'harvest=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call random_number(r)
+end
+
+subroutine c866_definition_contexts()
+ implicit none
+ integer, target :: x = 1
+ integer, pointer, protected_target :: p
+ character(4), target :: cx
+ character(4), pointer, protected_target :: cp
+ integer, allocatable :: a
+ integer :: u
+ namelist /grp/ p
+ p => x
+ cp => cx
+ !ERROR: Input variable 'p' is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ read *, p
+ !ERROR: 'p' may not be used as a DO variable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ do p = 1, 1
+ end do
+ !ERROR: IOSTAT variable 'p' is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ read(*, *, iostat=p) u
+ !ERROR: STAT variable 'p' is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ allocate(a, stat=p)
+ !ERROR: Internal file variable 'cp' is not definable
+ !BECAUSE: 'cp' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ write(cp, '(a)') 'ab'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'cp' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ cp(1:2) = 'cd'
+ !ERROR: NAMELIST input group must not contain undefinable item 'p'
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ read(*, nml=grp)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ if (.false.) p = 2
+end
+
+subroutine c866_intent_in_pointer_dummy(p)
+ integer, target :: x = 1
+ integer, pointer, protected_target, intent(in) :: p
+ print *, p
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ p => x
+end
+
+subroutine c866_intent_out_pointer_dummy(a)
+ integer, pointer, protected_target, intent(out) :: a
+ nullify(a)
+end
+
+subroutine c872_c874_select_rank_default(ar)
+ integer, pointer, protected_target :: ar(..)
+ integer, pointer :: q(:)
+ interface
+ subroutine plainptrar_rank(a)
+ integer, pointer :: a(..)
+ end
+ subroutine noint_rank(a)
+ integer :: a(..)
+ end
+ subroutine ptar_rank(a)
+ integer, pointer, protected_target :: a(..)
+ end
+ end interface
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call plainptrar_rank(ar)
+ !ERROR: Non-POINTER dummy argument 'a=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call noint_rank(ar)
+ select rank (a => ar)
+ rank (1)
+ q => a ! F'2028 draft 11.1.12.3p3 gives POINTER, but not PROTECTED_TARGET.
+ rank default
+ !ERROR: POINTER dummy argument 'a=' must have the PROTECTED_TARGET attribute when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call plainptrar_rank(a)
+ !ERROR: Non-POINTER dummy argument 'a=' must have INTENT(IN) when the actual argument is a PROTECTED_TARGET pointer or a subobject of one
+ call noint_rank(a)
+ call ptar_rank(a)
+ !ERROR: 'a' may not appear in NULLIFY
+ !BECAUSE: 'ar' is a PROTECTED_TARGET pointer, so its target may not be defined through it
+ nullify(a)
+ end select
+end
+
+module c864_owner_module_target
+ implicit none
+ integer, target, protected :: x = 1
+contains
+ subroutine ok
+ integer, pointer, protected_target :: p
+ p => x
+ end
+end
More information about the flang-commits
mailing list