[flang-commits] [flang] [flang] Add the PROTECTED_TARGET pointer attribute (PR #231426)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Tue Oct 13 02:36:12 PDT 2026
https://github.com/Saieiei created https://github.com/llvm/llvm-project/pull/231426
Add parsing and semantic checks for the Fortran 2028 working draft's PROTECTED_TARGET data-pointer attribute, including pointer components and attribute statements. Carry the attribute in module files and procedure metadata for pointer-target and call checks.
Diagnose target definition, protection-erasing associations and calls, COMMON membership including protected pointer components, and DEALLOCATE. Direct allocation requires SOURCE=; allocation through construct associates is rejected even with SOURCE=. Source-use checks and interface compatibility follow the draft's attribute rules, which permit some protection-erasing aliases and interface conversions.
J3/26-007r1 C864 conflicts with 8.5.16 NOTE 1. Follow C864 for direct use-associated nonpointer PROTECTED targets, including their association with PROTECTED_TARGET INTENT(IN) pointer dummies. Ordinary pointers keep the existing optional diagnostic for this association.
Assisted-by: GitHub Copilot
>From 83ff8602882c0a0d8eeef140b53db1c0078f3dfa Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Tue, 13 Oct 2026 04:35:58 -0500
Subject: [PATCH] [flang] Add the PROTECTED_TARGET pointer attribute
Add parsing and semantic checks for the Fortran 2028 working draft's PROTECTED_TARGET data-pointer attribute, including pointer components and attribute statements. Carry the attribute in module files and procedure metadata for pointer-target and call checks.
Diagnose target definition, protection-erasing associations and calls, COMMON membership including protected pointer components, and DEALLOCATE. Direct allocation requires SOURCE=; allocation through construct associates is rejected even with SOURCE=. Source-use checks and interface compatibility follow the draft's attribute rules, which permit some protection-erasing aliases and interface conversions.
J3/26-007r1 C864 conflicts with 8.5.16 NOTE 1. Follow C864 for direct use-associated nonpointer PROTECTED targets, including their association with PROTECTED_TARGET INTENT(IN) pointer dummies. Ordinary pointers keep the existing optional diagnostic for this association.
Assisted-by: GitHub Copilot
---
flang/docs/ReleaseNotes.md | 16 ++
.../include/flang/Evaluate/characteristics.h | 11 +-
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 20 +-
flang/include/flang/Semantics/attr.h | 4 +-
flang/include/flang/Semantics/tools.h | 20 ++
flang/lib/Evaluate/characteristics.cpp | 19 +-
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 | 6 +
flang/lib/Semantics/check-call.cpp | 11 ++
flang/lib/Semantics/check-deallocate.cpp | 6 +
flang/lib/Semantics/check-declarations.cpp | 27 ++-
flang/lib/Semantics/definable.cpp | 33 ++++
flang/lib/Semantics/pointer-assignment.cpp | 51 ++++-
flang/lib/Semantics/resolve-names.cpp | 14 +-
flang/lib/Semantics/tools.cpp | 72 +++++++
flang/test/Parser/typeof-classof-attrs.f90 | 10 +
flang/test/Semantics/allocate01.f90 | 71 +++++++
flang/test/Semantics/assign02.f90 | 121 ++++++++++++
flang/test/Semantics/assign03.f90 | 49 +++++
flang/test/Semantics/assign04.f90 | 129 +++++++++++++
flang/test/Semantics/call07.f90 | 181 ++++++++++++++++++
flang/test/Semantics/deallocate01.f90 | 50 +++++
flang/test/Semantics/modfile29.f90 | 43 +++++
flang/test/Semantics/resolve81.f90 | 41 +++-
flang/test/Semantics/separate-mp02.f90 | 64 +++++++
flang/test/Semantics/structconst02.f90 | 53 +++++
30 files changed, 1112 insertions(+), 27 deletions(-)
diff --git a/flang/docs/ReleaseNotes.md b/flang/docs/ReleaseNotes.md
index 609ca499da396..fec35281e576f 100644
--- a/flang/docs/ReleaseNotes.md
+++ b/flang/docs/ReleaseNotes.md
@@ -29,6 +29,22 @@ page](https://llvm.org/releases/).
## Major New Features
+- Added frontend support for the Fortran 2028 working draft's
+ `PROTECTED_TARGET` data pointer attribute and statement. Targets cannot be
+ defined through these pointers, and protection is checked in pointer
+ assignments, structure constructors and argument association. `ALLOCATE`
+ of a direct pointer requires `SOURCE=`, and `DEALLOCATE` is prohibited.
+ Allocation of such a pointer through a construct alias is rejected,
+ even with `SOURCE=`. The attribute is retained in module files and procedure
+ interfaces, but does not participate in interface compatibility checks.
+ Following J3/26-007r1, source-use constraints apply to aliases only when
+ their own attributes or subobjects carry protection; this does not provide
+ blanket protection through construct aliases or interface conversions.
+ For the conflict between
+ J3/26-007r1 C864 and 8.5.16 NOTE 1, Flang follows C864 and rejects association
+ of a `PROTECTED_TARGET` pointer with a use-associated nonpointer `PROTECTED`
+ target.
+
## Bug Fixes
- Fixed `fir::getTypeSizeAndAlignment` returning the wrong allocation size for
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 1ba0bf693c763..cc0f59f86ee19 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, ProtectedTarget, Target, DeducedFromActual,
+ OnlyIntrinsicInquiry)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
static bool IdenticalSignificantAttrs(const Attrs &x, const Attrs &y) {
- return (x - Attr::DeducedFromActual) == (y - Attr::DeducedFromActual);
+ // PROTECTED_TARGET is metadata, not a characteristic
+ // (J3/26-007r1 15.3.2.2).
+ 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,8 @@ using DummyArguments = std::vector<DummyArgument>;
// 15.3.3
struct FunctionResult {
- ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous)
+ // ProtectedTarget is metadata, not a characteristic (J3/26-007r1 15.3.3).
+ ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous, ProtectedTarget)
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..f02affbaf5715 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
@@ -386,9 +387,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 +997,11 @@ struct ComponentArraySpec {
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// PROTECTED_TARGET (F'2028) |
// (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 +1017,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;
};
@@ -1422,8 +1427,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 +1621,9 @@ WRAPPER_CLASS(PointerStmt, std::list<PointerDecl>);
// R855 protected-stmt -> PROTECTED [::] entity-name-list
WRAPPER_CLASS(ProtectedStmt, std::list<Name>);
+// F'2028 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..6cb5ccfca3ae9 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -150,6 +150,26 @@ const Symbol *FindImmediateComponent(
inline bool IsPointer(const Symbol &symbol) {
return symbol.attrs().test(Attr::POINTER);
}
+inline bool IsProtectedTarget(const Symbol &symbol) {
+ return symbol.attrs().test(Attr::PROTECTED_TARGET);
+}
+
+// The symbols on a designator's base path, without selectors or (co)subscripts.
+SymbolVector GetDesignatorSymbolVector(const evaluate::DataRef &);
+
+enum class ProtectedTargetContext {
+ Source,
+ Definition,
+ PointerAssociation,
+ Allocation
+};
+
+// Find the PROTECTED_TARGET pointer that protects this designator in context.
+// An intervening pointer's target is separate (J3/26-007r1 9.4.2p5).
+const Symbol *FindProtectedTarget(const evaluate::DataRef &,
+ ProtectedTargetContext = ProtectedTargetContext::Source);
+const Symbol *FindProtectedTarget(
+ const SomeExpr &, ProtectedTargetContext = ProtectedTargetContext::Source);
inline bool IsAllocatable(const Symbol &symbol) {
return symbol.attrs().test(Attr::ALLOCATABLE);
}
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 4b05a25fd8f58..c29b63e9ae38b 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)};
@@ -439,6 +441,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
{Attr::VALUE, DummyDataObject::Attr::Value},
{Attr::VOLATILE, DummyDataObject::Attr::Volatile},
{Attr::POINTER, DummyDataObject::Attr::Pointer},
+ {Attr::PROTECTED_TARGET, DummyDataObject::Attr::ProtectedTarget},
{Attr::TARGET, DummyDataObject::Attr::Target},
});
result->intent = GetIntent(symbol.attrs());
@@ -1059,8 +1062,9 @@ 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 (attrs - Attr::ProtectedTarget) ==
+ (that.attrs - Attr::ProtectedTarget) &&
+ cudaDataAttr == that.cudaDataAttr && u == that.u;
}
static std::optional<FunctionResult> CharacterizeFunctionResult(
@@ -1075,6 +1079,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;
@@ -1199,7 +1205,8 @@ bool FunctionResult::IsCompatibleWith(
if (!attrs.test(Attr::Contiguous)) {
actualAttrs.reset(Attr::Contiguous);
}
- if (attrs != actualAttrs) {
+ if ((attrs - Attr::ProtectedTarget) !=
+ (actualAttrs - Attr::ProtectedTarget)) {
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..9b5792a1ab5d3 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>(protectedTarget) ||
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>(protectedTarget) ||
+ construct<AttrSpec>(protectedAttr) ||
construct<AttrSpec>("RANK" >>
construct<RankClause>(parenthesized(scalarIntConstantExpr))) ||
construct<AttrSpec>(save) ||
@@ -1050,6 +1052,10 @@ TYPE_PARSER(
TYPE_PARSER(
construct<ProtectedStmt>("PROTECTED" >> maybe("::"_tok) >> listOfNames))
+// F'2028 R863 protected-target-stmt -> PROTECTED_TARGET [::] variable-name-list
+TYPE_PARSER(construct<ProtectedTargetStmt>(
+ "PROTECTED_TARGET" >> maybe("::"_tok) >> listOfNames))
+
// R856 save-stmt -> SAVE [[::] saved-entity-list]
TYPE_PARSER(construct<SaveStmt>(
"SAVE" >> defaulted(maybe("::"_tok) >>
diff --git a/flang/lib/Parser/misc-parsers.h b/flang/lib/Parser/misc-parsers.h
index 4a318e05bb4b8..355ca918b32e3 100644
--- a/flang/lib/Parser/misc-parsers.h
+++ b/flang/lib/Parser/misc-parsers.h
@@ -50,6 +50,8 @@ constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
+constexpr auto protectedTarget{
+ construct<ProtectedTarget>("PROTECTED_TARGET"_tok)};
constexpr auto save{construct<Save>("SAVE"_tok)};
template <typename A> common::IfNoLvalue<std::list<A>, A> singletonList(A &&x) {
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 08283a8be35e3..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..545a6d2798975 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 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..331d0399390fd 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -510,6 +510,12 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
"Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
return false;
}
+ if (IsProtectedTarget(*ultimate_) &&
+ !allocateInfo_.gotSource) { // F'2028 C869
+ context.Say(name_.source,
+ "An ALLOCATE statement for a PROTECTED_TARGET pointer must have a SOURCE= clause"_err_en_US);
+ 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..c9068a23915bd 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 (const Symbol *protectedPointer{
+ FindProtectedTarget(*expr)}) { // F'2028 C873
+ evaluate::SayWithDeclaration(messages, *protectedPointer,
+ "A PROTECTED_TARGET pointer or its subobject may not be an actual argument to a procedure with an implicit interface"_err_en_US);
+ }
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
@@ -399,6 +404,12 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
bool dummyIsPointer{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
+ if (!dummyIsPointer && dummy.intent != common::Intent::In &&
+ FindProtectedTarget(actual)) { // F'2028 C874
+ messages.Say(
+ "A PROTECTED_TARGET pointer or its subobject may be associated with nonpointer %s only if it has INTENT(IN)"_err_en_US,
+ dummyName);
+ }
bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer};
allowActualArgumentConversions &= !dummyIsAllocatableOrPointer;
bool typesCompatibleWithIgnoreTKR{
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index c93b940aa69ed..37163287d9d97 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 PROTECTED_TARGET pointer may not appear in a DEALLOCATE statement"_err_en_US);
} else if (auto whyNot{
WhyNotDefinable(source, context_.FindScope(source),
{DefinabilityFlag::PointerDefinition,
@@ -108,6 +111,9 @@ 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 (IsProtectedTarget(*symbol)) { // F'2028 C868
+ context_.Say(source,
+ "A PROTECTED_TARGET pointer may not appear 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..8351ad3a1bf52 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -350,6 +350,19 @@ void CheckHelper::Check(const Symbol &symbol) {
if (IsPointer(symbol)) {
CheckPointer(symbol);
}
+ if (symbol.attrs().test(Attr::PROTECTED_TARGET)) {
+ // J3/26-007r1 C781, C8109, and 8.5.16: this is a data pointer attribute.
+ if (!IsPointer(symbol) ||
+ (!symbol.has<ObjectEntityDetails>() &&
+ !symbol.has<AssocEntityDetails>())) {
+ messages_.Say(
+ "An entity with the PROTECTED_TARGET attribute must be a data pointer"_err_en_US);
+ }
+ if (FindCommonBlockContaining(symbol)) { // F'2028 C867
+ messages_.Say(
+ "A PROTECTED_TARGET pointer may not be in a common block"_err_en_US);
+ }
+ }
if (InPure()) {
if (InInterface()) {
// Declarations in interface definitions "have no effect" if they
@@ -601,6 +614,16 @@ void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
ref->name(), symbol.name()),
*ref);
} else if (const auto *derived{type->AsDerived()}) {
+ if (!IsPointer(*ref)) {
+ if (const Symbol *component{
+ FindUltimateComponent(*derived, IsProtectedTarget)}) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "COMMON block /%s/ may not contain PROTECTED_TARGET component '%s' of '%s'"_err_en_US,
+ symbol.name(), component->name(), ref->name()),
+ *component); // F'2028 C867
+ }
+ }
if (!IsSequenceOrBindCType(derived)) {
evaluate::AttachDeclaration(
evaluate::AttachDeclaration(
@@ -4177,7 +4200,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/definable.cpp b/flang/lib/Semantics/definable.cpp
index d6a654683001f..c786ff700daea 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -249,10 +249,26 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
return std::nullopt;
}
+static ProtectedTargetContext GetProtectedTargetContext(
+ DefinabilityFlags flags) {
+ if (!flags.test(DefinabilityFlag::PointerDefinition)) {
+ return ProtectedTargetContext::Definition;
+ }
+ return flags.test(DefinabilityFlag::AcceptAllocatable)
+ ? ProtectedTargetContext::Allocation
+ : ProtectedTargetContext::PointerAssociation;
+}
+
// Checks a data-ref
static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags,
const evaluate::DataRef &dataRef) {
+ if (const Symbol *protectedPointer{
+ FindProtectedTarget(dataRef, GetProtectedTargetContext(flags))}) {
+ return BlameSymbol(at,
+ "'%s' has the PROTECTED_TARGET attribute and its target is not definable"_en_US,
+ *protectedPointer);
+ }
auto whyNotBase{
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
@@ -270,6 +286,12 @@ 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 *protectedPointer{FindProtectedTarget(
+ evaluate::DataRef{original}, GetProtectedTargetContext(flags))}) {
+ return BlameSymbol(at,
+ "'%s' has the PROTECTED_TARGET attribute and its target is not definable"_en_US,
+ *protectedPointer);
+ }
auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
/*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
if (!whyNotBase || !whyNotBase->IsFatal()) {
@@ -412,6 +434,12 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
}
if (const auto *component{procDesignator->GetComponent()}) {
flags.reset(DefinabilityFlag::PointerDefinition);
+ if (const Symbol *protectedPointer{FindProtectedTarget(
+ component->base(), ProtectedTargetContext::Definition)}) {
+ return BlameSymbol(at,
+ "'%s' has the PROTECTED_TARGET attribute and its target is not definable"_en_US,
+ *protectedPointer);
+ }
return WhyNotDefinableBase(at, scope, flags,
component->base().GetFirstSymbol(), false,
DefinesComponentPointerTarget(component->base(), flags));
@@ -422,6 +450,11 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
}
return parser::Message{
at, "'%s' is not a definable pointer"_err_en_US, expr.AsFortran()};
+ } else if (const Symbol *protectedPointer{FindProtectedTarget(
+ expr, ProtectedTargetContext::Definition)}) {
+ return BlameSymbol(at,
+ "'%s' has the PROTECTED_TARGET attribute and its target is not definable"_en_US,
+ *protectedPointer);
} else if (!evaluate::IsVariable(expr)) {
return parser::Message{
at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..4850365dbc22b 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -50,10 +50,12 @@ 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));
}
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_isContiguous(bool);
PointerAssignmentChecker &set_isVolatile(bool);
+ PointerAssignmentChecker &set_isProtectedTarget(bool);
PointerAssignmentChecker &set_isBoundsRemapping(bool);
PointerAssignmentChecker &set_isAssumedRank(bool);
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
@@ -92,6 +94,7 @@ class PointerAssignmentChecker {
bool characterizedProcedure_{false};
bool isContiguous_{false};
bool isVolatile_{false};
+ bool isProtectedTarget_{false};
bool isBoundsRemapping_{false};
bool isAssumedRank_{false};
bool isRHSPointerActualArgument_{false};
@@ -117,6 +120,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isProtectedTarget(
+ bool isProtectedTarget) {
+ isProtectedTarget_ = isProtectedTarget;
+ return *this;
+}
+
PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
bool isBoundsRemapping) {
isBoundsRemapping_ = isBoundsRemapping;
@@ -207,6 +216,31 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
if (lhs_ && IsProcedure(*lhs_)) {
return true;
}
+ if (const Symbol *protectedPointer{FindProtectedTarget(rhs)};
+ protectedPointer && !isProtectedTarget_) { // F'2028 C870-C872
+ Say("Target '%s' with PROTECTED_TARGET attribute may not be associated with %s without PROTECTED_TARGET"_err_en_US,
+ protectedPointer->name(), description_);
+ return false;
+ }
+ if (isProtectedTarget_) {
+ if (auto dataRef{evaluate::ExtractDataRef(rhs, true, true)}) {
+ auto symbols{GetDesignatorSymbolVector(*dataRef)};
+ for (auto iter{symbols.rbegin()}; iter != symbols.rend(); ++iter) {
+ const Symbol &symbol{iter->get().GetUltimate()};
+ if (IsPointer(symbol)) {
+ break;
+ }
+ if (IsProtected(symbol) && IsUseAssociated(symbol, scope_)) {
+ // J3/26-007r1 C864 forbids this target despite the example in 8.5.16
+ // NOTE 1. Prefer the normative constraint; ordinary pointers keep
+ // their existing optional diagnostic.
+ Say("A PROTECTED_TARGET pointer may not be associated with use-associated nonpointer PROTECTED target '%s'"_err_en_US,
+ symbol.name());
+ return false;
+ }
+ }
+ }
+ }
if (const auto *pureProc{FindPureProcedureContaining(scope_)}) {
if (pointerComponentLHS_) { // F'2023 C15104(4) is a hard error
if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) {
@@ -244,12 +278,15 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
}
}
// 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;
+ if (!isProtectedTarget_) {
+ 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;
@@ -619,6 +656,8 @@ bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
.set_lhsType(common::Clone(lhs.type))
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
.set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
+ .set_isProtectedTarget(
+ lhs.attrs.test(DummyDataObject::Attr::ProtectedTarget))
.set_isAssumedRank(isAssumedRank)
.set_isRHSPointerActualArgument(isPointerActualArgument)
.set_ignoreTKR(lhs.ignoreTKR)
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 3571a1de521f7..1b8efe6a68f69 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 &) {
@@ -2688,6 +2690,12 @@ bool AttrsVisitor::Pre(const parser::Pass &x) {
bool AttrsVisitor::IsDuplicateAttr(Attr attrName) {
CHECK(attrs_);
if (attrs_->test(attrName)) {
+ if (attrName == Attr::PROTECTED_TARGET) {
+ Say(currStmtSource().value(),
+ "Attribute '%s' cannot be used more than once"_err_en_US,
+ AttrToString(attrName));
+ return true;
+ }
context().Warn(common::LanguageFeature::RedundantAttribute,
currStmtSource().value(),
"Attribute '%s' cannot be used more than once"_warn_en_US,
@@ -6763,6 +6771,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);
@@ -9346,7 +9357,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..8224faca5bd66 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"
@@ -25,6 +26,77 @@
namespace Fortran::semantics {
+SymbolVector GetDesignatorSymbolVector(const evaluate::DataRef &dataRef) {
+ auto componentSymbols{[](const evaluate::Component &component) {
+ auto symbols{GetDesignatorSymbolVector(component.base())};
+ symbols.emplace_back(component.GetLastSymbol());
+ return symbols;
+ }};
+ return common::visit(
+ common::visitors{
+ [](const SymbolRef &symbol) { return SymbolVector{symbol}; },
+ componentSymbols,
+ [&](const evaluate::ArrayRef &array) {
+ if (const auto *component{array.base().UnwrapComponent()}) {
+ return componentSymbols(*component);
+ }
+ return SymbolVector{array.base().GetLastSymbol()};
+ },
+ [](const evaluate::CoarrayRef &coarray) {
+ return GetDesignatorSymbolVector(coarray.base());
+ },
+ },
+ dataRef.u);
+}
+
+const Symbol *FindProtectedTarget(
+ const evaluate::DataRef &dataRef, ProtectedTargetContext context) {
+ auto symbols{GetDesignatorSymbolVector(dataRef)};
+ for (auto iter{symbols.rbegin()}; iter != symbols.rend(); ++iter) {
+ const Symbol &symbol{iter->get().GetUltimate()};
+ if (const auto *association{symbol.detailsIf<AssocEntityDetails>()};
+ association && association->expr() &&
+ context != ProtectedTargetContext::Source) {
+ // A selector in a definition context is not itself an allocate-object
+ // (J3/26-007r1 20.6.7(11), C866).
+ auto selectorContext{
+ context == ProtectedTargetContext::PointerAssociation &&
+ iter == symbols.rbegin()
+ ? ProtectedTargetContext::PointerAssociation
+ : ProtectedTargetContext::Definition};
+ return FindProtectedTarget(*association->expr(), selectorContext);
+ }
+ if (IsPointer(symbol)) {
+ if ((context == ProtectedTargetContext::PointerAssociation ||
+ context == ProtectedTargetContext::Allocation) &&
+ iter == symbols.rbegin()) {
+ continue;
+ }
+ return IsProtectedTarget(symbol) ? &symbol : nullptr;
+ }
+ }
+ return nullptr;
+}
+
+const Symbol *FindProtectedTarget(
+ const SomeExpr &expr, ProtectedTargetContext context) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
+ return FindProtectedTarget(*dataRef, context);
+ } else if ((context == ProtectedTargetContext::Source ||
+ context == ProtectedTargetContext::Definition) &&
+ evaluate::IsVariable(expr)) {
+ if (const auto *call{evaluate::UnwrapProcedureRef(expr)}) {
+ if (const Symbol *proc{call->proc().GetInterfaceSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*proc)};
+ result && IsProtectedTarget(*result)) {
+ return result;
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
// Find this or containing scope that matches predicate
static const Scope *FindScopeContaining(
const Scope &start, std::function<bool(const Scope &)> predicate) {
diff --git a/flang/test/Parser/typeof-classof-attrs.f90 b/flang/test/Parser/typeof-classof-attrs.f90
index d1be75dad8682..8dbd2d1b8284f 100644
--- a/flang/test/Parser/typeof-classof-attrs.f90
+++ b/flang/test/Parser/typeof-classof-attrs.f90
@@ -6,6 +6,8 @@ program test_program
TYPE :: matrix
INTEGER :: v
+ !CHECK: REAL, POINTER, PROTECTED_TARGET :: data
+ REAL, POINTER, PROTECTED_TARGET :: DATA
END TYPE
TYPE(matrix) :: MAT
@@ -19,4 +21,12 @@ program test_program
CLASSOF(MAT), POINTER :: CMAT_PTR
!CHECK: CLASSOF(mat), ALLOCATABLE, TARGET :: cmat_allocatable
CLASSOF(MAT), ALLOCATABLE, TARGET :: CMAT_ALLOCATABLE
+
+ !CHECK: TYPEOF(mat), POINTER, PROTECTED_TARGET :: protected_matrix
+ TYPEOF(MAT), POINTER, PROTECTED_TARGET :: PROTECTED_MATRIX
+ REAL, POINTER :: P, Q
+ !CHECK: PROTECTED_TARGET :: p
+ PROTECTED_TARGET P
+ !CHECK: PROTECTED_TARGET :: q
+ PROTECTED_TARGET :: Q
end program
diff --git a/flang/test/Semantics/allocate01.f90 b/flang/test/Semantics/allocate01.f90
index a10a7259ae94f..4bb32fe8cc921 100644
--- a/flang/test/Semantics/allocate01.f90
+++ b/flang/test/Semantics/allocate01.f90
@@ -122,3 +122,74 @@ subroutine bar()
allocate(rp)
allocate(character(123) :: chvar)
end subroutine
+
+! J3/26-007r1 C866 exception and C869.
+subroutine protected_target_allocation(p, ordinary)
+ real, pointer, protected_target :: p, a(:)
+ real, pointer :: ordinary
+ type node
+ real, pointer :: link
+ real, pointer, protected_target :: protected_link
+ end type
+ type(node), pointer, protected_target :: parent
+ type(node) :: object
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have a SOURCE= clause
+ allocate(p)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have a SOURCE= clause
+ allocate(p, mold=1.)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have a SOURCE= clause
+ allocate(real :: p)
+ allocate(p, source=1.)
+ allocate(a(2), source=1.)
+ allocate(object%protected_link, source=1.)
+ allocate(ordinary) ! An ordinary pointer does not require SOURCE=.
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'parent' has the PROTECTED_TARGET attribute and its target is not definable
+ allocate(parent%link, source=1.)
+ associate(q => parent)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'parent' has the PROTECTED_TARGET attribute and its target is not definable
+ allocate(q%link, source=1.)
+ end associate
+end subroutine
+
+! J3/26-007r1 C866 and 20.6.7(11): the selector is not an allocate-object.
+subroutine protected_target_rank_allocation(p)
+ real, pointer, protected_target :: p(..)
+ select rank(q => p)
+ rank(0)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ allocate(q)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ allocate(q, mold=1.)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ allocate(q, source=1.)
+ rank(1)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ allocate(q(2))
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ allocate(q(2), mold=[1., 2.])
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ allocate(q(2), source=1.)
+ end select
+end subroutine
+
+subroutine ordinary_rank_allocation(p)
+ real, pointer :: p(..)
+ select rank(q => p)
+ rank(0)
+ allocate(q)
+ allocate(q, mold=1.)
+ allocate(q, source=1.)
+ rank(1)
+ allocate(q(2))
+ allocate(q(2), mold=[1., 2.])
+ allocate(q(2), source=1.)
+ end select
+end subroutine
diff --git a/flang/test/Semantics/assign02.f90 b/flang/test/Semantics/assign02.f90
index c4470789476ad..5e311b1a03f65 100644
--- a/flang/test/Semantics/assign02.f90
+++ b/flang/test/Semantics/assign02.f90
@@ -250,3 +250,124 @@ subroutine s2
p => z
end associate
end
+
+! J3/26-007r1 C870 includes sections and nonpointer subobjects.
+module protected_target_assignment
+ type item
+ real :: value
+ real, pointer :: link
+ real, pointer, protected_target :: protected_link
+ end type
+ real, protected, target :: protected_value
+ integer, protected :: substring_bound = 1
+ real, target :: value, array(4)
+ real, pointer, protected_target :: rp, ap(:)
+ type(item), pointer, protected_target :: ip
+contains
+ function result_pointer() result(p)
+ real, pointer, protected_target :: p
+ p => value
+ end function
+ subroutine associations(input)
+ real, intent(in), target :: input
+ real, pointer :: ordinary, ordinary_array(:)
+ real, pointer, protected_target :: kept
+ character(4), pointer, protected_target :: cp
+ character(:), pointer :: ordinary_character
+ character(:), pointer, protected_target :: kept_character
+ character(4), target :: text
+ complex, pointer, protected_target :: zp
+ real, parameter :: constant = 1.
+ integer, pointer, protected_target :: index
+ rp => value
+ rp => input
+ rp => rp
+ ap => array
+ kept => ap(1)
+ !ERROR: Target 'cp' with PROTECTED_TARGET attribute may not be associated with pointer 'ordinary_character' without PROTECTED_TARGET
+ ordinary_character => cp(2:3)
+ !ERROR: Target 'zp' with PROTECTED_TARGET attribute may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => zp%re
+ !ERROR: Target 'rp' with PROTECTED_TARGET attribute may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => rp
+ !ERROR: Target 'ap' with PROTECTED_TARGET attribute may not be associated with pointer 'ordinary_array' without PROTECTED_TARGET
+ ordinary_array => ap(2:4)
+ !ERROR: Target 'ip' with PROTECTED_TARGET attribute may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => ip%value
+ kept => ip%value
+ ordinary => ip%link ! A different pointer's target is not protected by ip.
+ !ERROR: Target 'protected_link' with PROTECTED_TARGET attribute may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => ip%protected_link
+ !ERROR: Target 'p' with PROTECTED_TARGET attribute may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => result_pointer()
+ kept => result_pointer()
+ !ERROR: Target associated with pointer 'rp' must be a designator or a call to a pointer-valued function
+ rp => constant
+ kept => array(index) ! The index is not part of the target designator.
+ ordinary_character => text(index:index)
+ kept_character => text(index:index)
+ associate(a => text(index:index))
+ ordinary_character => a
+ kept_character => a
+ end associate
+ ! ASSOCIATE names do not inherit PROTECTED_TARGET (11.1.3.3).
+ associate(a => ap(2:4))
+ ordinary_array => a
+ end associate
+ associate(a => result_pointer())
+ ordinary => a
+ end associate
+ nullify(rp, ap, kept)
+ end subroutine
+
+ subroutine owner_association
+ rp => protected_value ! C864 only restricts use association.
+ end subroutine
+
+ subroutine ranked_sources(p)
+ real, pointer, protected_target :: p(..)
+ real, pointer :: ordinary, ordinary_array(:)
+ real, pointer, protected_target :: kept(:)
+ select rank(q => p)
+ rank(0)
+ ordinary => q
+ rank(1)
+ ordinary_array => q
+ rank default
+ ! RANK DEFAULT retains PROTECTED_TARGET (11.1.12.3p2).
+ !ERROR: Target 'q' with PROTECTED_TARGET attribute may not be associated with pointer 'ordinary_array' without PROTECTED_TARGET
+ ordinary_array(1:1) => q
+ kept(1:1) => q
+ end select
+ end subroutine
+end module
+
+subroutine protected_target_conflict
+ use protected_target_assignment, only: rp, protected_value
+ real, pointer :: ordinary
+ ! Follow normative J3/26-007r1 C864, not the contradictory 8.5.16 NOTE 1.
+ !ERROR: A PROTECTED_TARGET pointer may not be associated with use-associated nonpointer PROTECTED target 'protected_value'
+ rp => protected_value
+ ordinary => protected_value ! The optional pointer-to-undefinable warning is off.
+end subroutine
+
+module protected_target_initial_conflict
+ use protected_target_assignment, only: protected_value
+ ! C864 also applies to initial-data-target.
+ !ERROR: A PROTECTED_TARGET pointer may not be associated with use-associated nonpointer PROTECTED target 'protected_value'
+ real, pointer, protected_target :: p => protected_value
+end module
+
+subroutine protected_bound_association
+ use protected_target_assignment, only: substring_bound, protected_value
+ character(4), target :: text
+ character(:), pointer, protected_target :: p
+ real, pointer, protected_target :: value_pointer
+ p => text(substring_bound:substring_bound)
+ associate(q => text(substring_bound:substring_bound))
+ p => q
+ end associate
+ associate(q => protected_value)
+ value_pointer => q ! The associate name does not inherit PROTECTED.
+ end associate
+end subroutine
diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index d8e7f14238f92..a7c804cfa15fb 100644
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -1,6 +1,55 @@
! RUN: %python %S/test_errors.py %s %flang_fc1
! Pointer assignment constraints 10.2.2.2 (see also assign02.f90)
+module protected_target_characteristics
+ real, target :: storage
+contains
+ function protected_result() result(p)
+ real, pointer, protected_target :: p
+ p => storage
+ end function
+ function ordinary_result() result(p)
+ real, pointer :: p
+ p => storage
+ end function
+ subroutine protected_dummy(p)
+ real, pointer, protected_target :: p
+ end subroutine
+ subroutine ordinary_dummy(p)
+ real, pointer :: p
+ end subroutine
+ subroutine compatibility
+ procedure(protected_result), pointer :: fp
+ procedure(ordinary_result), pointer :: ordinary_fp
+ procedure(protected_dummy), pointer :: sp
+ procedure(ordinary_dummy), pointer :: ordinary_sp
+ fp => protected_result
+ ordinary_fp => ordinary_result
+ sp => protected_dummy
+ ! PROTECTED_TARGET is not a characteristic in J3/26-007r1 clause 15.
+ fp => ordinary_result
+ ordinary_fp => protected_result
+ sp => ordinary_dummy
+ ordinary_sp => protected_dummy
+ call takes_protected_result(ordinary_result)
+ call takes_ordinary_result(protected_result)
+ call takes_protected_dummy(ordinary_dummy)
+ call takes_ordinary_dummy(protected_dummy)
+ end subroutine
+ subroutine takes_protected_result(f)
+ procedure(protected_result) :: f
+ end subroutine
+ subroutine takes_ordinary_result(f)
+ procedure(ordinary_result) :: f
+ end subroutine
+ subroutine takes_protected_dummy(s)
+ procedure(protected_dummy) :: s
+ end subroutine
+ subroutine takes_ordinary_dummy(s)
+ procedure(ordinary_dummy) :: s
+ end subroutine
+end module
+
module m0
procedure(),pointer,save :: p
end
diff --git a/flang/test/Semantics/assign04.f90 b/flang/test/Semantics/assign04.f90
index 1cea1b6ef14e2..c9e4b405ef906 100644
--- a/flang/test/Semantics/assign04.f90
+++ b/flang/test/Semantics/assign04.f90
@@ -288,3 +288,132 @@ pure subroutine test(y1,y2,y3)
x3 = y3
end subroutine
end module m14
+
+! J3/26-007r1 C866 and 8.5.16p2 protect target values, not association status.
+module protected_target_definition
+ type node
+ real :: value
+ real, pointer :: link
+ type(node), pointer :: next
+ real, pointer, protected_target :: protected_link
+ end type
+ real, target :: storage
+ integer, protected :: substring_bound = 1
+contains
+ function readonly_result() result(p)
+ real, pointer, protected_target :: p
+ p => storage
+ end function
+ subroutine definitions(p, ordinary_in, index)
+ real, pointer, protected_target :: p(:)
+ real, pointer, intent(in) :: ordinary_in
+ integer, pointer, protected_target :: index
+ type(node), pointer, protected_target :: parent
+ character(4), pointer, protected_target :: text
+ complex, pointer, protected_target :: z
+ character(4), target :: ordinary_text
+ real, target :: value
+ real :: a(4)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ p = 1.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ if (.false.) p(1:2) = 2.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'text' has the PROTECTED_TARGET attribute and its target is not definable
+ text(2:3) = 'ab'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'z' has the PROTECTED_TARGET attribute and its target is not definable
+ z%re = 1.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'parent' has the PROTECTED_TARGET attribute and its target is not definable
+ parent%value = 1.
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'parent' has the PROTECTED_TARGET attribute and its target is not definable
+ parent%link => value
+ parent%link = 1. ! An ordinary pointer component's target is separate.
+ parent%next%value = 1.
+ parent%next%link => value
+ ordinary_in = 1. ! INTENT(IN) alone still protects only association.
+ a(index) = 1. ! A protected index does not make a protected designator.
+ ordinary_text(index:index) = 'a'
+ associate(q => ordinary_text(index:index))
+ q = 'a'
+ end associate
+ associate(q => a(index))
+ q = 1.
+ end associate
+ !ERROR: Input variable 'p' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ read(*,*) p
+ associate(q => p(1:2))
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ q = 1.
+ end associate
+ associate(q => parent)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'parent' has the PROTECTED_TARGET attribute and its target is not definable
+ q%value = 1.
+ q%link = 1.
+ end associate
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ readonly_result() = 1.
+ associate(q => readonly_result())
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ q = 1.
+ end associate
+ end subroutine
+ subroutine ranked(p)
+ real, pointer, protected_target :: p(..)
+ real, target :: value, array(2)
+ select rank(q => p)
+ rank(0)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ q = 1.
+ q => value
+ nullify(q)
+ !ERROR: Target 'p' with PROTECTED_TARGET attribute may not be associated with pointer 'q' without PROTECTED_TARGET
+ q => readonly_result()
+ rank(1)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ q = 1.
+ q => array
+ nullify(q)
+ end select
+ end subroutine
+ subroutine selected(p)
+ class(node), pointer, protected_target :: p
+ select type(q => p)
+ type is(node)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ q%value = 1.
+ q%link = 1.
+ end select
+ end subroutine
+ subroutine association_only(p)
+ real, pointer, protected_target, intent(in) :: p
+ real, target :: value
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ p => value
+ !ERROR: 'p' may not appear in NULLIFY
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ nullify(p)
+ end subroutine
+end module
+
+subroutine protected_bound_definition
+ use protected_target_definition, only: substring_bound
+ character(4) :: text
+ text(substring_bound:substring_bound) = 'a'
+ associate(q => text(substring_bound:substring_bound))
+ q = 'a'
+ end associate
+end subroutine
diff --git a/flang/test/Semantics/call07.f90 b/flang/test/Semantics/call07.f90
index 7e29fb74dd615..5eb57b4a09102 100644
--- a/flang/test/Semantics/call07.f90
+++ b/flang/test/Semantics/call07.f90
@@ -49,3 +49,184 @@ subroutine test
call s03(a04)
end subroutine
end module
+
+! J3/26-007r1 C872-C874.
+module protected_target_calls
+ type node
+ real :: value
+ real, pointer :: link
+ end type
+ real, target :: storage
+ integer, protected :: substring_bound = 1
+contains
+ function readonly_result() result(p)
+ real, pointer, protected_target :: p
+ p => storage
+ end function
+ subroutine pointer_in(p)
+ real, pointer, protected_target, intent(in) :: p
+ end subroutine
+ subroutine pointer_out(p)
+ real, pointer, protected_target, intent(out) :: p
+ end subroutine
+ subroutine ordinary_pointer(p)
+ real, pointer, intent(in) :: p
+ end subroutine
+ subroutine read_value(x)
+ real, intent(in) :: x
+ end subroutine
+ subroutine write_value(x)
+ real, intent(out) :: x
+ end subroutine
+ subroutine unspecified(x)
+ real :: x
+ end subroutine
+ subroutine read_array(x)
+ real, intent(in) :: x(:)
+ end subroutine
+ subroutine ordinary_assumed_rank(p)
+ real, pointer, intent(out) :: p(..)
+ end subroutine
+ subroutine protected_assumed_rank(p)
+ real, pointer, protected_target, intent(out) :: p(..)
+ end subroutine
+ subroutine unspecified_assumed_rank(x)
+ real :: x(..)
+ end subroutine
+ subroutine write_assumed_rank(x)
+ real, intent(out) :: x(..)
+ end subroutine
+ subroutine unspecified_character(x)
+ character(*) :: x
+ end subroutine
+ subroutine write_character(x)
+ character(*), intent(out) :: x
+ end subroutine
+ subroutine test_calls(p, a)
+ real, pointer, protected_target :: p, a(:)
+ real, pointer :: ordinary
+ real :: value
+ logical :: associated_value
+ integer :: count
+ external implicit
+ call pointer_in(p)
+ call pointer_out(p) ! Only association status is being defined.
+ call pointer_in(ordinary)
+ call pointer_out(ordinary)
+ call read_value(p)
+ call read_value(a(1))
+ call read_array(a(2:))
+ call unspecified(p+0.) ! An expression is not a protected subobject.
+ call unspecified((p))
+ call read_value(readonly_result())
+ !ERROR: Target 'p' with PROTECTED_TARGET attribute may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call ordinary_pointer(readonly_result())
+ call pointer_in(readonly_result())
+ !ERROR: A PROTECTED_TARGET pointer or its subobject may be associated with nonpointer dummy argument 'x=' only if it has INTENT(IN)
+ call unspecified(readonly_result())
+ value = sum(a)
+ count = size(a)
+ associated_value = associated(p)
+ !ERROR: Target 'p' with PROTECTED_TARGET attribute may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call ordinary_pointer(p)
+ !ERROR: Target 'a' with PROTECTED_TARGET attribute may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call ordinary_pointer(a(1))
+ !ERROR: A PROTECTED_TARGET pointer or its subobject may be associated with nonpointer dummy argument 'x=' only if it has INTENT(IN)
+ call unspecified(p)
+ !ERROR: A PROTECTED_TARGET pointer or its subobject may be associated with nonpointer dummy argument 'x=' only if it has INTENT(IN)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ call write_value(p)
+ !ERROR: A PROTECTED_TARGET pointer or its subobject may not be an actual argument to a procedure with an implicit interface
+ call implicit(p)
+ !ERROR: A PROTECTED_TARGET pointer or its subobject may not be an actual argument to a procedure with an implicit interface
+ call implicit(a(1))
+ !ERROR: A PROTECTED_TARGET pointer or its subobject may be associated with nonpointer dummy argument 'harvest=' only if it has INTENT(IN)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'harvest=' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ call random_number(p)
+ associate(q => p)
+ call read_value(q)
+ call unspecified(q)
+ call implicit(q)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ call write_value(q)
+ end associate
+ end subroutine
+ subroutine subobjects(parent)
+ class(node), pointer, protected_target :: parent
+ call read_value(parent%value)
+ call unspecified(parent%link)
+ !ERROR: Target 'parent' with PROTECTED_TARGET attribute may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call ordinary_pointer(parent%value)
+ select type(q => parent)
+ type is(node)
+ call read_value(q%value)
+ call unspecified(q%link)
+ call unspecified(q%value)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'parent' has the PROTECTED_TARGET attribute and its target is not definable
+ call write_value(q%value)
+ end select
+ end subroutine
+ subroutine ranked_calls(p)
+ real, pointer, protected_target :: p(..)
+ external implicit
+ select rank(q => p)
+ rank(0)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ call ordinary_assumed_rank(q)
+ call protected_assumed_rank(q)
+ call unspecified(q)
+ call implicit(q)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ call write_value(q)
+ rank(1)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ call ordinary_assumed_rank(q)
+ call protected_assumed_rank(q)
+ call unspecified_assumed_rank(q)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ call write_assumed_rank(q)
+ rank default
+ !ERROR: Target 'q' with PROTECTED_TARGET attribute may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call ordinary_assumed_rank(q)
+ call protected_assumed_rank(q)
+ !ERROR: A PROTECTED_TARGET pointer or its subobject may be associated with nonpointer dummy argument 'x=' only if it has INTENT(IN)
+ call unspecified_assumed_rank(q)
+ !ERROR: A PROTECTED_TARGET pointer or its subobject may be associated with nonpointer dummy argument 'x=' only if it has INTENT(IN)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ call write_assumed_rank(q)
+ end select
+ end subroutine
+ subroutine substring_calls(index)
+ integer, pointer, protected_target :: index
+ character(4), target :: text
+ external implicit_text
+ call unspecified_character(text(index:index))
+ call write_character(text(index:index))
+ associate(q => text(index:index))
+ call unspecified_character(q)
+ call implicit_text(q)
+ call write_character(q)
+ end associate
+ end subroutine
+end module
+
+subroutine protected_bound_calls
+ use protected_target_calls, only: substring_bound, &
+ unspecified_character, write_character
+ character(4) :: text
+ external implicit_text
+ associate(q => text(substring_bound:substring_bound))
+ call unspecified_character(q)
+ call implicit_text(q)
+ call write_character(q)
+ end associate
+end subroutine
diff --git a/flang/test/Semantics/deallocate01.f90 b/flang/test/Semantics/deallocate01.f90
index b224f30df4569..63a2e67870e62 100644
--- a/flang/test/Semantics/deallocate01.f90
+++ b/flang/test/Semantics/deallocate01.f90
@@ -47,3 +47,53 @@
Deallocate(z, y, stat=s)
End Program
+
+! J3/26-007r1 C868 and target/subobject definition.
+subroutine protected_target_deallocation
+ type node
+ real, pointer :: link
+ type(node), pointer :: next
+ real, pointer, protected_target :: protected_link
+ end type
+ real, pointer, protected_target :: p
+ type(node) :: object
+ type(node), pointer, protected_target :: parent
+ !ERROR: A PROTECTED_TARGET pointer may not appear in a DEALLOCATE statement
+ deallocate(p)
+ !ERROR: A PROTECTED_TARGET pointer may not appear in a DEALLOCATE statement
+ deallocate(object%protected_link)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'parent' has the PROTECTED_TARGET attribute and its target is not definable
+ deallocate(parent%link)
+ deallocate(parent%next%link) ! The descriptor belongs to a different target.
+ associate(q => parent)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'parent' has the PROTECTED_TARGET attribute and its target is not definable
+ deallocate(q%link)
+ end associate
+end subroutine
+
+! J3/26-007r1 C866 and 20.6.7(9),(11).
+subroutine protected_target_rank_deallocation(p)
+ real, pointer, protected_target :: p(..)
+ select rank(q => p)
+ rank(0)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ deallocate(q)
+ rank(1)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+ deallocate(q)
+ end select
+end subroutine
+
+subroutine ordinary_rank_deallocation(p)
+ real, pointer :: p(..)
+ select rank(q => p)
+ rank(0)
+ deallocate(q)
+ rank(1)
+ deallocate(q)
+ end select
+end subroutine
diff --git a/flang/test/Semantics/modfile29.f90 b/flang/test/Semantics/modfile29.f90
index 7650fe301b289..eafe15fad3dae 100644
--- a/flang/test/Semantics/modfile29.f90
+++ b/flang/test/Semantics/modfile29.f90
@@ -1,4 +1,7 @@
! RUN: %python %S/test_modfile.py %s %flang_fc1
+! RUN: mkdir -p %t
+! RUN: %flang_fc1 -fsyntax-only -module-dir %t %s
+! RUN: cd %t && printf '%%s\n' 'subroutine test' 'use m' 'integer, pointer :: local' 'type(t) :: object' 'k=1' 'object%%p=1' 'local=>getter()' 'call consume(k)' 'end' | not %flang_fc1 -fsyntax-only -I %t -x f95 - 2>&1 | FileCheck %s --check-prefix=READ
! Check that implicitly typed entities get a type in the module file.
module m
@@ -6,6 +9,20 @@ module m
private :: b
protected :: i
allocatable :: j
+ pointer :: k, n
+ protected_target k
+ protected_target :: n
+ type t
+ integer, pointer, protected_target :: p
+ end type
+ interface
+ subroutine consume(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end subroutine
+ function getter() result(p)
+ integer, pointer, protected_target :: p
+ end function
+ end interface
end
!Expect: m.mod
@@ -14,4 +31,30 @@ module m
! real(4),private::b
! integer(4),protected::i
! integer(4),allocatable::j
+! integer(4),pointer,protected_target::k
+! integer(4),pointer,protected_target::n
+! type::t
+! integer(4),pointer,protected_target::p
+! end type
+! interface
+! subroutine consume(p)
+! integer(4),intent(in),pointer,protected_target::p
+! end
+! end interface
+! interface
+! function getter() result(p)
+! integer(4),pointer,protected_target::p
+! end
+! end interface
!end
+
+!READ: error: Semantic errors in -
+!READ-NOT: error:
+!READ: error: Left-hand side of assignment is not definable
+!READ: because: 'k' has the PROTECTED_TARGET attribute and its target is not definable
+!READ-NOT: error:
+!READ: error: Left-hand side of assignment is not definable
+!READ: because: 'p' has the PROTECTED_TARGET attribute and its target is not definable
+!READ-NOT: error:
+!READ: error: Target 'p' with PROTECTED_TARGET attribute may not be associated with pointer 'local' without PROTECTED_TARGET
+!READ-NOT: error:
diff --git a/flang/test/Semantics/resolve81.f90 b/flang/test/Semantics/resolve81.f90
index 23651cbb257e7..0df2b50e272ca 100644
--- a/flang/test/Semantics/resolve81.f90
+++ b/flang/test/Semantics/resolve81.f90
@@ -7,7 +7,8 @@
! attr-spec values are:
! PUBLIC, PRIVATE, ALLOCATABLE, ASYNCHRONOUS, CODIMENSION, CONTIGUOUS,
! DIMENSION (array-spec), EXTERNAL, INTENT (intent-spec), INTRINSIC,
-! BIND(C), OPTIONAL, PARAMETER, POINTER, PROTECTED, SAVE, TARGET, VALUE,
+! BIND(C), OPTIONAL, PARAMETER, POINTER, PROTECTED, PROTECTED_TARGET,
+! SAVE, TARGET, VALUE,
! VOLATILE
module m
@@ -64,3 +65,41 @@ subroutine testTypeDecl(arg1, arg2, arg3, arg4, arg5, arg6)
arg2 =3.5
end subroutine testTypeDecl
end module m
+
+! J3/26-007r1 C781, C8109 and 8.5.16: data pointers only.
+module protected_target_declarations
+ real, pointer, protected_target :: p
+ real, pointer :: q, r
+ protected_target q
+ protected_target :: r
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ real, protected_target :: nonpointer
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ real :: statement_nonpointer
+ protected_target :: statement_nonpointer
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ procedure(), pointer :: procedure_pointer
+ protected_target procedure_pointer
+ !ERROR: Attribute 'PROTECTED_TARGET' cannot be used more than once
+ real, pointer, protected_target, protected_target :: duplicate
+ type good
+ real, pointer, protected_target :: p
+ end type
+ type bad
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ real, protected_target :: p
+ end type
+ !ERROR: A PROTECTED_TARGET pointer may not be in a common block
+ real, pointer, protected_target :: common_pointer
+ common /direct/ common_pointer
+ type common_type
+ sequence
+ real, pointer, protected_target :: p
+ end type
+ type(common_type) :: common_object
+ !ERROR: COMMON block /nested/ may not contain PROTECTED_TARGET component 'p' of 'common_object'
+ common /nested/ common_object
+ ! A pointer's target, unlike its descriptor, is not in the common block.
+ type(common_type), pointer :: ordinary_common_pointer
+ common /ordinary/ ordinary_common_pointer
+end module
diff --git a/flang/test/Semantics/separate-mp02.f90 b/flang/test/Semantics/separate-mp02.f90
index 7d8ea6e0c3932..8ccc41450f2de 100644
--- a/flang/test/Semantics/separate-mp02.f90
+++ b/flang/test/Semantics/separate-mp02.f90
@@ -6,6 +6,70 @@
! - C1550: binding label
! - C1551: NON_RECURSIVE prefix
+module protected_target_interface
+ interface
+ module subroutine protected_dummy(p)
+ real, pointer, protected_target :: p
+ end subroutine
+ module subroutine ordinary_dummy(p)
+ real, pointer :: p
+ end subroutine
+ module function protected_result() result(p)
+ real, pointer, protected_target :: p
+ end function
+ module function ordinary_result() result(p)
+ real, pointer :: p
+ end function
+ module subroutine dummy_procedure(s)
+ interface
+ subroutine s(p)
+ real, pointer, protected_target :: p
+ end subroutine
+ end interface
+ end subroutine
+ module subroutine dummy_function(f)
+ interface
+ function f() result(p)
+ real, pointer, protected_target :: p
+ end function
+ end interface
+ end subroutine
+ end interface
+end module
+
+submodule(protected_target_interface) protected_target_implementation
+contains
+ ! PROTECTED_TARGET is not a characteristic in J3/26-007r1 clause 15.
+ module subroutine protected_dummy(p)
+ real, pointer :: p
+ end subroutine
+ module subroutine ordinary_dummy(p)
+ real, pointer, protected_target :: p
+ end subroutine
+ module function protected_result() result(p)
+ real, pointer :: p
+ nullify(p)
+ end function
+ module function ordinary_result() result(p)
+ real, pointer, protected_target :: p
+ nullify(p)
+ end function
+ module subroutine dummy_procedure(s)
+ interface
+ subroutine s(p)
+ real, pointer :: p
+ end subroutine
+ end interface
+ end subroutine
+ module subroutine dummy_function(f)
+ interface
+ function f() result(p)
+ real, pointer :: p
+ end function
+ end interface
+ end subroutine
+end submodule
+
module m1
interface
module subroutine s4(x)
diff --git a/flang/test/Semantics/structconst02.f90 b/flang/test/Semantics/structconst02.f90
index 71d6b720fb41a..68efdc358f453 100644
--- a/flang/test/Semantics/structconst02.f90
+++ b/flang/test/Semantics/structconst02.f90
@@ -45,3 +45,56 @@ subroutine errors(n)
!TODO more!
end subroutine errors
end module module1
+
+! J3/26-007r1 C871 preserves protection in pointer components.
+module protected_target_constructor
+ type ordinary_box
+ real, pointer :: p
+ end type
+ type protected_box
+ real, pointer, protected_target :: p
+ end type
+ type ordinary_text_box
+ character(:), pointer :: p
+ end type
+ type protected_text_box
+ character(:), pointer, protected_target :: p
+ end type
+ type object
+ real :: value
+ real, pointer :: link
+ end type
+contains
+ subroutine constructors
+ real, pointer, protected_target :: p, a(:)
+ real, pointer :: ordinary
+ type(object), pointer, protected_target :: parent
+ type(ordinary_box) :: writable
+ type(protected_box) :: kept
+ type(ordinary_text_box) :: writable_text
+ type(protected_text_box) :: kept_text
+ character(4), target :: text
+ integer, pointer, protected_target :: index
+ kept = protected_box(p)
+ kept = protected_box(a(1))
+ kept = protected_box(ordinary)
+ kept = protected_box(null())
+ writable = ordinary_box(ordinary)
+ writable = ordinary_box(parent%link)
+ !ERROR: Target 'p' with PROTECTED_TARGET attribute may not be associated with pointer 'p' without PROTECTED_TARGET
+ writable = ordinary_box(p)
+ !ERROR: Target 'a' with PROTECTED_TARGET attribute may not be associated with pointer 'p' without PROTECTED_TARGET
+ writable = ordinary_box(a(1))
+ !ERROR: Target 'parent' with PROTECTED_TARGET attribute may not be associated with pointer 'p' without PROTECTED_TARGET
+ writable = ordinary_box(parent%value)
+ associate(q => p)
+ writable = ordinary_box(q) ! The associate has no PROTECTED_TARGET attribute.
+ end associate
+ writable_text = ordinary_text_box(text(index:index))
+ kept_text = protected_text_box(text(index:index))
+ associate(q => text(index:index))
+ writable_text = ordinary_text_box(q)
+ kept_text = protected_text_box(q)
+ end associate
+ end subroutine
+end module
More information about the flang-commits
mailing list