[flang-commits] [flang] [flang] Draft: Fortran 2028 pointer-target protection (CI only, not for review) (PR #230865)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Sat Oct 10 15:15:21 PDT 2026
https://github.com/Saieiei created https://github.com/llvm/llvm-project/pull/230865
This draft exists only to run pre-merge CI on alternative implementations of a Fortran 2028 attribute while we evaluate them internally. It is not intended for review or merge; please ignore it. It will be closed when the CI runs are complete.
The code in each pushed revision was written with AI assistance (see the Assisted-by trailer in the commit message) and has passed local build, Flang lit and format checks before being pushed.
>From afd511089420e0e73f4fc9704094b09e06e3cbeb Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Sat, 10 Oct 2026 17:15:02 -0500
Subject: [PATCH] [flang] Draft: Fortran 2028 pointer-target protection
attribute
CI-only draft for an internal evaluation (arm A0); not for review.
Assisted-by: GitHub Copilot (Claude Opus 5.5, GPT-6.1 Sol)
---
flang/docs/ReleaseNotes.md | 5 +
.../include/flang/Evaluate/characteristics.h | 8 +-
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 | 12 +
flang/lib/Evaluate/characteristics.cpp | 9 +-
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 | 5 +
flang/lib/Semantics/check-call.cpp | 27 +-
flang/lib/Semantics/check-deallocate.cpp | 6 +
flang/lib/Semantics/check-declarations.cpp | 14 +-
flang/lib/Semantics/definable.cpp | 17 +
flang/lib/Semantics/pointer-assignment.cpp | 44 +-
flang/lib/Semantics/resolve-names.cpp | 12 +-
flang/lib/Semantics/tools.cpp | 58 +++
flang/test/Lower/protected-target.f90 | 31 ++
flang/test/Parser/protected-target.f90 | 26 +
.../Semantics/modfile-protected-target.f90 | 57 +++
flang/test/Semantics/protected-target01.f90 | 275 +++++++++++
flang/test/Semantics/protected-target02.f90 | 448 ++++++++++++++++++
24 files changed, 1070 insertions(+), 25 deletions(-)
create mode 100644 flang/test/Lower/protected-target.f90
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-target01.f90
create mode 100644 flang/test/Semantics/protected-target02.f90
diff --git a/flang/docs/ReleaseNotes.md b/flang/docs/ReleaseNotes.md
index 609ca499da396..60e829b0eb392 100644
--- a/flang/docs/ReleaseNotes.md
+++ b/flang/docs/ReleaseNotes.md
@@ -29,6 +29,11 @@ page](https://llvm.org/releases/).
## Major New Features
+- Added frontend support for the Fortran 2028 draft `PROTECTED_TARGET`
+ data-pointer attribute. The compiler diagnoses target definition through
+ these pointers and checks protection propagation, allocation, and argument
+ association.
+
## 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..968e72d1cd48b 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 not a characteristic of a dummy data object
+ // (F2028 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} {}
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..55e989d5fe056 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -173,6 +173,7 @@ struct ParameterStmt; // R851
struct OldParameterStmt;
struct PointerStmt; // R853
struct ProtectedStmt; // R855
+struct ProtectedTargetStmt; // F2028 R863
struct SaveStmt; // R856
struct TargetStmt; // R859
struct ValueStmt; // R861
@@ -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 |
+// (F2028) PROTECTED_TARGET |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE | UNIFIED
EMPTY_CLASS(Allocatable);
EMPTY_CLASS(Pointer);
+EMPTY_CLASS(ProtectedTarget);
EMPTY_CLASS(Contiguous);
// CUDA-data-attr [( IMPLICIT )]
// The (IMPLICIT) qualifier marks an attribute that the compiler applied on the
@@ -1013,7 +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>);
+// F2028 R863 protected-target-stmt -> PROTECTED_TARGET [::] variable-name-list
+WRAPPER_CLASS(ProtectedTargetStmt, std::list<Name>);
+
// R857 saved-entity -> object-name | proc-pointer-name | / common-block-name /
// R858 proc-pointer-name -> name
struct SavedEntity {
diff --git a/flang/include/flang/Semantics/attr.h b/flang/include/flang/Semantics/attr.h
index d8b323e88f650..8a76ac6d50bab 100644
--- a/flang/include/flang/Semantics/attr.h
+++ b/flang/include/flang/Semantics/attr.h
@@ -23,8 +23,8 @@ namespace Fortran::semantics {
ENUM_CLASS(Attr, ABSTRACT, ALLOCATABLE, ASYNCHRONOUS, BIND_C, CONTIGUOUS,
DEFERRED, ELEMENTAL, EXTENDS, EXTERNAL, IMPURE, INTENT_IN, INTENT_INOUT,
INTENT_OUT, INTRINSIC, MODULE, NON_OVERRIDABLE, NON_RECURSIVE, NOPASS,
- OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PUBLIC, PURE,
- RECURSIVE, SAVE, SIMPLE, TARGET, VALUE, VOLATILE)
+ OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PROTECTED_TARGET,
+ PUBLIC, PURE, RECURSIVE, SAVE, SIMPLE, TARGET, VALUE, VOLATILE)
// Set of attributes
class Attrs : public common::EnumSet<Attr, Attr_enumSize> {
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index d91a7d11a38c9..c4d38ac26eaf8 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -178,6 +178,18 @@ 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);
+}
+// Returns the PROTECTED_TARGET pointer through which the designated object is
+// reached, if any. With isPointerDefinition, the designated pointer itself is
+// skipped.
+const Symbol *FindProtectedTarget(
+ const Symbol &, bool isPointerDefinition = false);
+const Symbol *FindProtectedTarget(
+ const evaluate::DataRef &, bool isPointerDefinition = false);
+const Symbol *FindProtectedTarget(
+ const SomeExpr &, bool isPointerDefinition = false);
inline bool IsImpliedDoIndex(const Symbol &symbol) {
return symbol.owner().kind() == Scope::Kind::ImpliedDos;
}
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 4b05a25fd8f58..906bba8726925 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());
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 263ce9249a8b2..b0fc5642d68d6 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -476,6 +476,7 @@ TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(contiguous) ||
construct<ComponentAttrSpec>("DIMENSION" >> componentArraySpec) ||
construct<ComponentAttrSpec>(pointer) ||
+ construct<ComponentAttrSpec>(protectedTargetAttr) ||
extension<LanguageFeature::CUDA>(
construct<ComponentAttrSpec>(Parser<CUDADataAttrSpec>{})) ||
construct<ComponentAttrSpec>(recovery(
@@ -756,7 +757,8 @@ TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
construct<AttrSpec>(construct<Intrinsic>("INTRINSIC"_tok)) ||
construct<AttrSpec>(languageBindingSpec) || construct<AttrSpec>(optional) ||
construct<AttrSpec>(construct<Parameter>("PARAMETER"_tok)) ||
- construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedAttr) ||
+ construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedTargetAttr) ||
+ construct<AttrSpec>(protectedAttr) ||
construct<AttrSpec>("RANK" >>
construct<RankClause>(parenthesized(scalarIntConstantExpr))) ||
construct<AttrSpec>(save) ||
@@ -1050,6 +1052,10 @@ TYPE_PARSER(
TYPE_PARSER(
construct<ProtectedStmt>("PROTECTED" >> maybe("::"_tok) >> listOfNames))
+// F2028 R863 protected-target-stmt -> PROTECTED_TARGET [::] variable-name-list
+TYPE_PARSER(construct<ProtectedTargetStmt>(
+ "PROTECTED_TARGET" >> maybe("::"_tok) >> listOfNames))
+
// R856 save-stmt -> SAVE [[::] saved-entity-list]
TYPE_PARSER(construct<SaveStmt>(
"SAVE" >> defaulted(maybe("::"_tok) >>
diff --git a/flang/lib/Parser/misc-parsers.h b/flang/lib/Parser/misc-parsers.h
index 4a318e05bb4b8..c191b5ba36a78 100644
--- a/flang/lib/Parser/misc-parsers.h
+++ b/flang/lib/Parser/misc-parsers.h
@@ -50,6 +50,8 @@ constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
+constexpr auto protectedTargetAttr{
+ construct<ProtectedTarget>("PROTECTED_TARGET"_tok)};
constexpr auto save{construct<Save>("SAVE"_tok)};
template <typename A> common::IfNoLvalue<std::list<A>, A> singletonList(A &&x) {
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 08283a8be35e3..933214037ed2d 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -232,6 +232,7 @@ TYPE_PARSER(first(
construct<OtherSpecificationStmt>(indirect(Parser<NamelistStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<OptionalStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<PointerStmt>{})),
+ construct<OtherSpecificationStmt>(indirect(Parser<ProtectedTargetStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<ProtectedStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<SaveStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<TargetStmt>{})),
diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp
index a046c08e710c6..20513f6d376e4 100644
--- a/flang/lib/Parser/unparse.cpp
+++ b/flang/lib/Parser/unparse.cpp
@@ -634,6 +634,7 @@ class UnparseVisitor {
void Post(const Optional &) { Word("OPTIONAL"); }
void Post(const Parameter &) { Word("PARAMETER"); }
void Post(const Protected &) { Word("PROTECTED"); }
+ void Post(const ProtectedTarget &) { Word("PROTECTED_TARGET"); }
void Post(const Save &) { Word("SAVE"); }
void Post(const Target &) { Word("TARGET"); }
void Post(const Value &) { Word("VALUE"); }
@@ -719,6 +720,9 @@ class UnparseVisitor {
void Unparse(const ProtectedStmt &x) { // R855
Word("PROTECTED :: "), Walk(x.v, ", ");
}
+ void Unparse(const ProtectedTargetStmt &x) { // F2028 R863
+ Word("PROTECTED_TARGET :: "), Walk(x.v, ", ");
+ }
void Unparse(const SaveStmt &x) { // R856
Word("SAVE"), Walk(" :: ", x.v, ", ");
}
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index e797b978c4bd3..3f5ea1f680bbe 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -510,6 +510,11 @@ 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) { // F2028 C869
+ context.Say(name_.source,
+ "An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE="_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..ccf9b27da1cdd 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -67,6 +67,12 @@ 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 *pointer{FindProtectedTarget(*expr)}) { // F2028 C873
+ evaluate::SayWithDeclaration(messages, *pointer,
+ "PROTECTED_TARGET pointer '%s' or its subobject requires an explicit interface"_err_en_US,
+ pointer->name());
+ return;
+ }
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
@@ -399,6 +405,18 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
bool dummyIsPointer{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
+ const Symbol *protectedTargetActual{
+ scope ? FindProtectedTarget(actual) : nullptr};
+ // Intrinsic dummies without explicit intent have INTENT(IN) (F2028 17.2.1).
+ bool badProtectedTargetActual{!dummyIsPointer &&
+ dummy.intent != common::Intent::In &&
+ !(intrinsic && dummy.intent == common::Intent::Default) &&
+ protectedTargetActual};
+ if (badProtectedTargetActual) { // F2028 C874
+ evaluate::SayWithDeclaration(messages, *protectedTargetActual,
+ "PROTECTED_TARGET pointer '%s' or its subobject requires INTENT(IN) for nonpointer %s"_err_en_US,
+ protectedTargetActual->name(), dummyName);
+ }
bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer};
allowActualArgumentConversions &= !dummyIsAllocatableOrPointer;
bool typesCompatibleWithIgnoreTKR{
@@ -829,7 +847,14 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// Definability checking
// Problems with polymorphism are caught in the callee's definition.
- if (scope) {
+ // Pointer-association checking below diagnoses F2028 C872.
+ bool badProtectedTargetPointerActual{scope && dummyIsPointer &&
+ !dummy.attrs.test(
+ characteristics::DummyDataObject::Attr::ProtectedTarget) &&
+ (protectedTargetActual ||
+ (actualIsPointer &&
+ FindProtectedTarget(actual, /*isPointerDefinition=*/true)))};
+ if (scope && !badProtectedTargetActual && !badProtectedTargetPointerActual) {
std::optional<parser::MessageFixedText> undefinableMessage;
DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
if (dummy.intent == common::Intent::InOut) {
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index c93b940aa69ed..18cb1e4ecf2c0 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)) { // F2028 C868
+ context_.Say(source,
+ "A PROTECTED_TARGET pointer may not be deallocated"_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)) { // F2028 C868
+ context_.Say(source,
+ "A PROTECTED_TARGET pointer may not be deallocated"_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..522b3e8f00801 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -347,6 +347,16 @@ void CheckHelper::Check(const Symbol &symbol) {
"A PROTECTED entity may not be in a common block"_err_en_US);
}
}
+ if (IsProtectedTarget(symbol)) { // F2028 C781, C8109, 8.5.16
+ if (!IsPointer(symbol) || IsProcedure(symbol)) {
+ messages_.Say(
+ "A PROTECTED_TARGET entity must be a data pointer"_err_en_US);
+ }
+ if (FindCommonBlockContaining(symbol)) { // F2028 C867
+ messages_.Say(
+ "A PROTECTED_TARGET pointer may not be in a common block"_err_en_US);
+ }
+ }
if (IsPointer(symbol)) {
CheckPointer(symbol);
}
@@ -4177,7 +4187,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..59e152bae5624 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -253,6 +253,12 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags,
const evaluate::DataRef &dataRef) {
+ if (const Symbol *pointer{FindProtectedTarget(
+ dataRef, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable"_en_US,
+ *pointer);
+ }
auto whyNotBase{
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
@@ -270,6 +276,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 *pointer{FindProtectedTarget(
+ original, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable"_en_US,
+ *pointer);
+ }
auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
/*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
if (!whyNotBase || !whyNotBase->IsFatal()) {
@@ -397,6 +409,11 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
if (auto whyNotDataRef{WhyNotDefinable(at, scope, flags, *dataRef)}) {
return whyNotDataRef;
}
+ } else if (const Symbol *pointer{FindProtectedTarget(
+ expr, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable"_en_US,
+ *pointer);
} else if (evaluate::IsNullPointerOrAllocatable(&expr)) {
return parser::Message{
at, "'%s' is a null pointer"_err_en_US, expr.AsFortran()};
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..919c269c160c7 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,20 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
if (lhs_ && IsProcedure(*lhs_)) {
return true;
}
+ if (!isProtectedTarget_) { // F2028 C870-C872
+ const Symbol *pointer{FindProtectedTarget(rhs)};
+ if (!pointer && isRHSPointerActualArgument_) {
+ pointer = FindProtectedTarget(rhs, /*isPointerDefinition=*/true);
+ }
+ if (pointer) {
+ if (auto *msg{Say(
+ "PROTECTED_TARGET pointer '%s' or its subobject may not be associated with %s without PROTECTED_TARGET"_err_en_US,
+ pointer->name(), description_)}) {
+ evaluate::AttachDeclaration(*msg, *pointer);
+ }
+ return false;
+ }
+ }
if (const auto *pureProc{FindPureProcedureContaining(scope_)}) {
if (pointerComponentLHS_) { // F'2023 C15104(4) is a hard error
if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) {
@@ -243,13 +266,18 @@ 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;
+ // Skip the optional undefinable-target warning for PROTECTED_TARGET pointers:
+ // nothing can be defined through them. Follow F2028 8.5.16 NOTE 1 where it
+ // conflicts with C864.
+ 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 +647,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..f21994ca88726 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -299,6 +299,7 @@ class AttrsVisitor : public virtual BaseVisitor {
HANDLE_ATTR_CLASS(Parameter, PARAMETER)
HANDLE_ATTR_CLASS(Pointer, POINTER)
HANDLE_ATTR_CLASS(Protected, PROTECTED)
+ HANDLE_ATTR_CLASS(ProtectedTarget, PROTECTED_TARGET)
HANDLE_ATTR_CLASS(Save, SAVE)
HANDLE_ATTR_CLASS(Target, TARGET)
HANDLE_ATTR_CLASS(Value, VALUE)
@@ -1090,6 +1091,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool Pre(const parser::IntrinsicStmt &);
bool Pre(const parser::OptionalStmt &);
bool Pre(const parser::ProtectedStmt &);
+ bool Pre(const parser::ProtectedTargetStmt &);
bool Pre(const parser::ValueStmt &);
bool Pre(const parser::VolatileStmt &);
bool Pre(const parser::AllocatableStmt &) {
@@ -6763,6 +6765,9 @@ bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) {
bool DeclarationVisitor::Pre(const parser::ProtectedStmt &x) {
return HandleAttributeStmt(Attr::PROTECTED, x.v);
}
+bool DeclarationVisitor::Pre(const parser::ProtectedTargetStmt &x) {
+ return HandleAttributeStmt(Attr::PROTECTED_TARGET, x.v);
+}
bool DeclarationVisitor::Pre(const parser::ValueStmt &x) {
return CheckNotInBlock("VALUE") && // C1107
HandleAttributeStmt(Attr::VALUE, x.v);
@@ -9334,7 +9339,9 @@ void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
if (auto expr{EvaluateIntExpr(*rankValue)}) {
if (auto val{evaluate::ToInt64(*expr)}) {
details.set_rank(*val);
- attrsToKeep |= Attrs{Attr::ALLOCATABLE, Attr::POINTER};
+ // Keep PROTECTED_TARGET with POINTER to protect the associate name.
+ attrsToKeep |=
+ Attrs{Attr::ALLOCATABLE, Attr::POINTER, Attr::PROTECTED_TARGET};
} else {
Say("RANK() expression must be constant"_err_en_US);
}
@@ -9346,7 +9353,8 @@ void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
CHECK(std::holds_alternative<parser::Default>(x.u));
// RANK DEFAULT: assumed-rank
details.set_IsAssumedRank();
- attrsToKeep |= Attrs{Attr::ALLOCATABLE, Attr::POINTER};
+ attrsToKeep |=
+ Attrs{Attr::ALLOCATABLE, Attr::POINTER, Attr::PROTECTED_TARGET};
}
symbol->attrs() |= selectorAttrs & attrsToKeep;
}
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 48ff27f214649..50a2ff83972e8 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,63 @@ bool IsPointerDummy(const Symbol &symbol) {
return IsPointer(symbol) && IsDummy(symbol);
}
+static const Symbol *FindProtectedTarget(
+ const SymbolVector &symbols, bool isPointerDefinition) {
+ for (auto it{symbols.rbegin()}; it != symbols.rend(); ++it) {
+ const Symbol &symbol{it->get().GetUltimate()};
+ if (isPointerDefinition) {
+ isPointerDefinition = false;
+ continue;
+ }
+ if (IsPointer(symbol)) {
+ // Where a pointer component's target is referenced, it is not a subobject
+ // of the base object. The component is a subobject in contexts concerning
+ // its own pointer association (F2028 9.4.2p5).
+ return IsProtectedTarget(symbol) ? &symbol : nullptr;
+ }
+ if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()};
+ assoc && assoc->expr() && evaluate::IsVariable(*assoc->expr())) {
+ return FindProtectedTarget(*assoc->expr());
+ }
+ }
+ return nullptr;
+}
+
+const Symbol *FindProtectedTarget(
+ const Symbol &symbol, bool isPointerDefinition) {
+ return FindProtectedTarget(
+ evaluate::GetSymbolVector(symbol), isPointerDefinition);
+}
+
+const Symbol *FindProtectedTarget(
+ const evaluate::DataRef &dataRef, bool isPointerDefinition) {
+ return FindProtectedTarget(
+ evaluate::GetSymbolVector(dataRef), isPointerDefinition);
+}
+
+const Symbol *FindProtectedTarget(
+ const SomeExpr &expr, bool isPointerDefinition) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
+ return FindProtectedTarget(*dataRef, isPointerDefinition);
+ } else if (isPointerDefinition) {
+ if (const auto *proc{std::get_if<evaluate::ProcedureDesignator>(&expr.u)}) {
+ if (const auto *component{proc->GetComponent()}) {
+ return FindProtectedTarget(component->base());
+ }
+ }
+ } else {
+ if (const auto *ref{evaluate::UnwrapProcedureRef(expr)}) {
+ if (const Symbol *proc{ref->proc().GetSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*proc)};
+ result && IsProtectedTarget(*result)) {
+ return result;
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
bool IsBindCProcedure(const Symbol &original) {
const Symbol &symbol{original.GetUltimate()};
if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
diff --git a/flang/test/Lower/protected-target.f90 b/flang/test/Lower/protected-target.f90
new file mode 100644
index 0000000000000..aa375c665b0ec
--- /dev/null
+++ b/flang/test/Lower/protected-target.f90
@@ -0,0 +1,31 @@
+! RUN: %flang_fc1 -emit-hlfir %s -o - | FileCheck %s
+
+module protected_target_lowering
+ type t
+ integer, pointer, protected_target :: c
+ end type
+contains
+ function copy_pointer(p) result(q)
+ integer, pointer, protected_target, intent(in) :: p
+ integer, pointer, protected_target :: q
+ q => p
+ end
+ subroutine allocate_pointer(p)
+ integer, pointer, protected_target :: p
+ allocate(p, source=1)
+ end
+ subroutine component(p, a)
+ integer, pointer, protected_target, intent(in) :: p
+ type(t), intent(out) :: a
+ a = t(p)
+ end
+end
+
+! CHECK-LABEL: func.func @_QMprotected_target_loweringPcopy_pointer(
+! CHECK-SAME: !fir.ref<!fir.box<!fir.ptr<i32>>>
+! CHECK-SAME: -> !fir.box<!fir.ptr<i32>>
+! CHECK-LABEL: func.func @_QMprotected_target_loweringPallocate_pointer(
+! CHECK-SAME: !fir.ref<!fir.box<!fir.ptr<i32>>>
+! CHECK: fir.call @_FortranAPointerAllocateSource(
+! CHECK-LABEL: func.func @_QMprotected_target_loweringPcomponent(
+! CHECK-SAME: !fir.ref<!fir.box<!fir.ptr<i32>>>
diff --git a/flang/test/Parser/protected-target.f90 b/flang/test/Parser/protected-target.f90
new file mode 100644
index 0000000000000..f824f2261ef37
--- /dev/null
+++ b/flang/test/Parser/protected-target.f90
@@ -0,0 +1,26 @@
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s | FileCheck %s
+! RUN: %flang_fc1 -ffixed-form -fdebug-unparse-no-sema %s | FileCheck %s
+! RUN: %flang_fc1 -fdebug-dump-parse-tree %s | FileCheck %s --check-prefix=DUMP
+
+ module protected_target_syntax
+ integer, pointer, protected_target :: p
+ integer, pointer :: q, r
+ protected_target q
+ PROTECTED_TARGET :: r
+ integer, pointer, protected :: ordinary
+ type t
+ integer, protected_target, pointer :: c
+ end type
+ end module
+
+! CHECK: MODULE protected_target_syntax
+! CHECK: INTEGER, POINTER, PROTECTED_TARGET :: p
+! CHECK: PROTECTED_TARGET :: q
+! CHECK-NEXT: PROTECTED_TARGET :: r
+! CHECK-NEXT: INTEGER, POINTER, PROTECTED :: ordinary
+! CHECK: INTEGER, PROTECTED_TARGET, POINTER :: c
+! DUMP: ProtectedTarget
+! DUMP: ProtectedTargetStmt
+! DUMP: ProtectedTargetStmt
+! DUMP: Protected{{$}}
+! DUMP: ProtectedTarget
diff --git a/flang/test/Semantics/modfile-protected-target.f90 b/flang/test/Semantics/modfile-protected-target.f90
new file mode 100644
index 0000000000000..7cc7fc0675b7f
--- /dev/null
+++ b/flang/test/Semantics/modfile-protected-target.f90
@@ -0,0 +1,57 @@
+! RUN: split-file %s %t
+! RUN: %flang_fc1 -fsyntax-only -module-dir %t %t/m.f90
+! RUN: FileCheck %s --check-prefix=MOD < %t/pt_module.mod
+! RUN: %flang_fc1 -fsyntax-only -Wpointer-to-undefinable -module-dir %t %t/valid.f90
+! RUN: not %flang_fc1 -fsyntax-only -module-dir %t %t/invalid.f90 2>&1 | FileCheck %s --implicit-check-not=error:
+
+!--- m.f90
+module pt_module
+ integer, target, protected :: x
+ integer, pointer, protected_target :: p
+ type t
+ integer, pointer, protected_target :: c
+ end type
+contains
+ subroutine read_pointer(a)
+ integer, pointer, protected_target, intent(in) :: a
+ end
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => x
+ end
+end
+
+!--- valid.f90
+subroutine valid
+ use pt_module
+ type(t) :: obj
+ integer, pointer :: w
+ p => x
+ p => get()
+ obj = t(p)
+ call read_pointer(p)
+ call read_pointer(w)
+ print *, p, obj%c
+ nullify(p)
+end
+
+!--- invalid.f90
+subroutine invalid
+ use pt_module
+ type(t) :: obj
+ integer, pointer :: w
+ p = 1
+ obj%c = 1
+ w => get()
+end
+
+! MOD-DAG: integer(4),pointer,protected_target::p
+! MOD-DAG: integer(4),pointer,protected_target::c
+! MOD-DAG: integer(4),intent(in),pointer,protected_target::a
+! MOD-DAG: integer(4),pointer,protected_target::r
+! CHECK: error: Semantic errors in
+! CHECK: error: Left-hand side of assignment is not definable
+! CHECK: because: The target of PROTECTED_TARGET pointer 'p' is not definable
+! CHECK: error: Left-hand side of assignment is not definable
+! CHECK: because: The target of PROTECTED_TARGET pointer 'c' is not definable
+! CHECK: error: PROTECTED_TARGET pointer 'r' or its subobject may not be associated with pointer 'w' without PROTECTED_TARGET
diff --git a/flang/test/Semantics/protected-target01.f90 b/flang/test/Semantics/protected-target01.f90
new file mode 100644
index 0000000000000..be02faf9c44fd
--- /dev/null
+++ b/flang/test/Semantics/protected-target01.f90
@@ -0,0 +1,275 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+subroutine declarations
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ integer, protected_target :: not_pointer
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ integer, allocatable, protected_target :: not_pointer_either
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ integer :: statement_not_pointer
+ protected_target :: statement_not_pointer
+ protected_target ordered
+ integer :: ordered
+ pointer :: ordered
+ type bad_component
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ integer, protected_target :: c
+ end type
+ interface
+ subroutine proc_interface
+ end subroutine
+ end interface
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ interface generic
+ subroutine specific
+ end subroutine
+ end interface
+ protected_target generic
+ !ERROR: A PROTECTED_TARGET entity must be a data pointer
+ procedure(proc_interface), pointer :: proc
+ protected_target proc
+ !ERROR: A PROTECTED_TARGET pointer may not be in a common block
+ integer, pointer, protected_target :: common_pointer
+ common /blk/ common_pointer
+end
+
+subroutine common_components
+ ! x, not its pointer component, is in COMMON (F2028 8.11.3.1p3).
+ type inner
+ sequence
+ integer, pointer, protected_target :: p
+ end type
+ type outer
+ sequence
+ type(inner) :: c
+ end type
+ type(outer) :: x
+ type(outer), pointer :: ordinary
+ common /components/ x
+ common /pointers/ ordinary
+end
+
+subroutine allocation
+ type t
+ integer, pointer, protected_target :: c
+ end type
+ type(t) :: x
+ integer, pointer, protected_target :: p, q(:)
+ integer, pointer :: ordinary
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(p)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(p, mold=1)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(integer :: p)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(x%c)
+ allocate(p, x%c, source=1)
+ allocate(q, source=[1, 2])
+ allocate(ordinary)
+ !ERROR: A PROTECTED_TARGET pointer may not be deallocated
+ deallocate(p)
+ !ERROR: A PROTECTED_TARGET pointer may not be deallocated
+ deallocate(x%c)
+ deallocate(ordinary)
+ nullify(p, q, x%c)
+end
+
+module definitions
+ type t
+ integer :: value, array(2)
+ character(4) :: text
+ complex :: z
+ integer, allocatable :: a
+ integer, pointer :: link
+ integer, pointer, protected_target :: ro
+ procedure(), pointer, nopass :: proc
+ end type
+contains
+ subroutine scalar_and_sections
+ integer, target :: x, y(2)
+ integer, pointer, protected_target :: p, q(:)
+ character(4), target :: text
+ character(:), pointer, protected_target :: chars
+ complex, target :: z
+ complex, pointer, protected_target :: c
+ p => x
+ q => y
+ chars => text
+ c => z
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ if (.false.) p = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'q' is not definable
+ q(1:2) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'q' is not definable
+ q([1, 2]) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'chars' is not definable
+ chars(1:2) = 'ab'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'c' is not definable
+ c%re = 1
+ !ERROR: Input variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ read *, p
+ print *, x
+ !ERROR: IOSTAT variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ read (*, *, iostat=p) x
+ y(p) = 1
+ x = 2
+ print *, p, q, chars, c, associated(p), size(q), len(chars)
+ p => y(1)
+ nullify(p, q, chars, c)
+ end
+
+ subroutine components_and_associations
+ type(t), target :: x
+ type(t), pointer, protected_target :: p
+ integer, target :: target
+ p => x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p%value = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p%array(1) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p%text(1:1) = 'a'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p%z%im = 1
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p%link => target
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p%proc => callee
+ !ERROR: 'proc' may not appear in NULLIFY
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ nullify(p%proc)
+ call p%proc()
+ x%proc => callee
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ allocate(p%a, source=1)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ deallocate(p%a)
+ ! The target of an ordinary pointer component is not a subobject of p.
+ p%link = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'ro' is not definable
+ x%ro = 1
+ x%ro => target
+ associate(a => p%array)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ a(1) = 1
+ end associate
+ associate(a => p)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ a%value = 1
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ a%link => target
+ a%link = 1
+ end associate
+ nullify(p)
+ end
+
+ subroutine callee
+ end
+
+ subroutine association_status(p, x, ordinary)
+ integer, pointer, protected_target, intent(in) :: p
+ integer, target, intent(in) :: x
+ integer, pointer, intent(in) :: ordinary
+ integer, pointer, protected_target :: q
+ q => x
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ p => x
+ !ERROR: 'p' may not appear in NULLIFY
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ nullify(p)
+ ordinary = 1
+ nullify(q)
+ end
+
+ subroutine definition_contexts
+ integer, pointer, protected_target :: p
+ character(16), pointer, protected_target :: text
+ logical, pointer, protected_target :: exists
+ integer, allocatable :: a
+ integer :: x
+ namelist /group/ p
+ !ERROR: 'p' may not be used as a DO variable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ do p = 1, 2
+ end do
+ !ERROR: The target of PROTECTED_TARGET pointer 'p' is not definable
+ print *, (x, p = 1, 2)
+ !ERROR: NAMELIST input group must not contain undefinable item 'p'
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ read (*, nml=group)
+ write (*, nml=group)
+ !ERROR: Internal file variable 'text' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'text' is not definable
+ write (text, *) x
+ !ERROR: NEWUNIT variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ open (newunit=p, status='scratch')
+ !ERROR: EXIST variable 'exists' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'exists' is not definable
+ inquire (file='file', exist=exists)
+ !ERROR: IOMSG variable 'text' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'text' is not definable
+ read (*, *, iostat=x, iomsg=text) x
+ !ERROR: STAT variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ allocate(a, stat=p)
+ !ERROR: ERRMSG variable 'text' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'text' is not definable
+ deallocate(a, stat=x, errmsg=text)
+ end
+
+ subroutine type_guard(p)
+ class(t), pointer, protected_target :: p
+ select type (alias => p)
+ type is (t)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ alias%value = 1
+ print *, alias%value
+ end select
+ end
+
+ subroutine rank_guard(p, q)
+ integer, pointer, protected_target :: p(..)
+ integer, pointer, protected_target :: q(:)
+ select rank (alias => p)
+ rank (1)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ alias(1) = 1
+ print *, alias
+ nullify(alias)
+ alias => q
+ !ERROR: A PROTECTED_TARGET pointer may not be deallocated
+ deallocate(alias)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(alias(2))
+ rank default
+ nullify(alias)
+ end select
+ end
+end module
diff --git a/flang/test/Semantics/protected-target02.f90 b/flang/test/Semantics/protected-target02.f90
new file mode 100644
index 0000000000000..53c603efdac5e
--- /dev/null
+++ b/flang/test/Semantics/protected-target02.f90
@@ -0,0 +1,448 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Wpointer-to-undefinable -Wmismatching-dummy-procedure
+
+module targets
+ integer, target, protected :: x
+ type t
+ integer :: value
+ integer, pointer :: link
+ contains
+ procedure :: passed_unspecified
+ end type
+ type(t), target, protected :: obj
+ type writable
+ integer, pointer :: c
+ end type
+ type readonly
+ integer, pointer, protected_target :: c
+ end type
+ interface generic_value
+ module procedure value_inout
+ end interface
+ interface generic_pointer
+ module procedure pointer_in
+ end interface
+ interface assignment(=)
+ module procedure set_value
+ end interface
+contains
+ subroutine owner
+ integer, pointer, protected_target :: p
+ p => x
+ p => obj%value
+ print *, p
+ end
+ function get() result(p)
+ integer, pointer, protected_target :: p
+ p => x
+ end
+ subroutine pointer_in(p)
+ integer, pointer, intent(in) :: p
+ end
+ subroutine pointer_unspecified(p)
+ integer, pointer :: p
+ nullify(p)
+ end
+ subroutine pointer_out(p)
+ integer, pointer, intent(out) :: p
+ nullify(p)
+ end
+ subroutine pointer_inout(p)
+ integer, pointer, intent(inout) :: p
+ nullify(p)
+ end
+ subroutine readonly_in(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end
+ subroutine readonly_unspecified(p)
+ integer, pointer, protected_target :: p
+ nullify(p)
+ end
+ subroutine readonly_out(p)
+ integer, pointer, protected_target, intent(out) :: p
+ nullify(p)
+ end
+ subroutine readonly_inout(p)
+ integer, pointer, protected_target, intent(inout) :: p
+ nullify(p)
+ end
+ subroutine value_in(a)
+ integer, intent(in) :: a
+ end
+ subroutine value_out(a)
+ integer, intent(out) :: a
+ end
+ subroutine value_inout(a)
+ integer, intent(inout) :: a
+ end
+ subroutine value_unspecified(a)
+ integer :: a
+ end
+ subroutine value_only(a)
+ integer, value :: a
+ end
+ subroutine passed_unspecified(self)
+ class(t) :: self
+ end
+ elemental subroutine elemental_inout(a)
+ integer, intent(inout) :: a
+ end
+ subroutine set_value(a, b)
+ type(t), intent(out) :: a
+ integer, intent(in) :: b
+ a%value = b
+ end
+end
+
+subroutine associations
+ use targets
+ integer, target :: local, array(2)
+ integer, pointer :: w, section(:)
+ integer, pointer, protected_target :: p, q, pa(:)
+ type(t), pointer, protected_target :: pt
+ type(writable) :: a
+ type(readonly) :: b
+ ! Follow F2028 8.5.16 NOTE 1 despite its conflict with C864.
+ p => x
+ p => obj%value
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ w => x
+ w => local
+ p => w
+ q => p
+ pa => array
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be associated with pointer 'w' without PROTECTED_TARGET
+ w => p
+ !ERROR: PROTECTED_TARGET pointer 'pa' or its subobject may not be associated with pointer 'section' without PROTECTED_TARGET
+ section => pa(1:2)
+ pt => obj
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject may not be associated with pointer 'w' without PROTECTED_TARGET
+ w => pt%value
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be associated with pointer 'c' without PROTECTED_TARGET
+ a = writable(p)
+ b = readonly(p)
+ !ERROR: PROTECTED_TARGET pointer 'pa' or its subobject may not be associated with pointer 'c' without PROTECTED_TARGET
+ a = writable(pa(1))
+ b = readonly(pa(1))
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be associated with pointer 'w' without PROTECTED_TARGET
+ w => get()
+ p => get()
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be associated with pointer 'c' without PROTECTED_TARGET
+ a = writable(get())
+ b = readonly(get())
+ associate(alias => pa(1:2))
+ !ERROR: PROTECTED_TARGET pointer 'pa' or its subobject may not be associated with pointer 'section' without PROTECTED_TARGET
+ section => alias
+ end associate
+ nullify(p, q, pa, pt)
+end
+
+subroutine initial_data_targets
+ use targets, only: x
+ ! Follow F2028 8.5.16 NOTE 1 for initial-data-targets too.
+ integer, pointer, protected_target, save :: p => x
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ integer, pointer, save :: ordinary => x
+end
+
+subroutine calls
+ use targets
+ integer, pointer, protected_target :: p, pa(:)
+ type(t), pointer, protected_target :: pt
+ external implicit_interface
+ call readonly_in(p)
+ call readonly_out(p)
+ call readonly_inout(p)
+ call value_in(p)
+ call value_in(pa(1))
+ call value_in(pt%value)
+ call value_in(get())
+ call readonly_in(get())
+ call readonly_in(pa(1))
+ call readonly_in(x)
+ call value_out(pt%link)
+ call value_unspecified((p))
+ call value_unspecified(p + 1)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call pointer_in(p)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call pointer_in(get())
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call pointer_in(pt%value)
+ !ERROR: PROTECTED_TARGET pointer 'pa' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call pointer_in(pa(1))
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call value_out(p)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call value_inout(p)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call value_unspecified(p)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call value_only(p)
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject requires INTENT(IN) for nonpointer dummy argument 'self='
+ call pt%passed_unspecified()
+ !ERROR: PROTECTED_TARGET pointer 'pa' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call elemental_inout(pa)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call generic_value(p)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call generic_pointer(p)
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable
+ pt = 3
+ !ERROR: PROTECTED_TARGET pointer 'pa' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call value_unspecified(pa(1))
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call value_unspecified(pt%value)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject requires an explicit interface
+ call implicit_interface(p)
+ !ERROR: PROTECTED_TARGET pointer 'pa' or its subobject requires an explicit interface
+ call implicit_interface(pa(1:2))
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject requires an explicit interface
+ call implicit_interface(pt%value)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject requires an explicit interface
+ call implicit_interface(get())
+ associate(alias => pt%value)
+ call value_in(alias)
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call value_unspecified(alias)
+ end associate
+ associate(alias => get())
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ alias = 1
+ call value_in(alias)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject requires INTENT(IN) for nonpointer dummy argument 'a='
+ call value_unspecified(alias)
+ end associate
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ get() = 1
+end
+
+subroutine pointer_component_actuals
+ use targets
+ type(t), pointer, protected_target :: pt
+ integer, pointer :: w
+ type(t) :: value
+ w => pt%link
+ value = t(pt%link, w)
+ call value_in(pt%link)
+ call value_out(pt%link)
+ pt%link = 1
+ call readonly_in(pt%link)
+ call readonly_unspecified(pt%link)
+ call pointer_in(value%link)
+ call pointer_unspecified(value%link)
+ call pointer_out(value%link)
+ call pointer_inout(value%link)
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call pointer_in(pt%link)
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call pointer_unspecified(pt%link)
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call pointer_out(pt%link)
+ !ERROR: PROTECTED_TARGET pointer 'pt' or its subobject may not be associated with dummy argument 'p=' without PROTECTED_TARGET
+ call pointer_inout(pt%link)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'p=' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable
+ call readonly_out(pt%link)
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'p=' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'pt' is not definable
+ call readonly_inout(pt%link)
+end
+
+subroutine intrinsic_arguments
+ real, pointer, protected_target :: r, a(:)
+ integer, pointer, protected_target :: i, ia(:)
+ character(:), pointer, protected_target :: c
+ real, pointer :: ordinary
+ integer :: ordinary_integer
+ r => null(r)
+ r => null(mold=r)
+ a => null(a)
+ a => null(mold=a)
+ ordinary => null(r)
+ ordinary => null(ordinary)
+ !ERROR: PROTECTED_TARGET pointer 'r' or its subobject requires INTENT(IN) for nonpointer dummy argument 'harvest='
+ call random_number(r)
+ !ERROR: PROTECTED_TARGET pointer 'r' or its subobject requires INTENT(IN) for nonpointer dummy argument 'harvest='
+ call random_number(harvest=r)
+ !ERROR: PROTECTED_TARGET pointer 'a' or its subobject requires INTENT(IN) for nonpointer dummy argument 'harvest='
+ call random_number(a)
+ !ERROR: PROTECTED_TARGET pointer 'c' or its subobject requires INTENT(IN) for nonpointer dummy argument 'command='
+ call get_command(command=c)
+ !ERROR: PROTECTED_TARGET pointer 'i' or its subobject requires INTENT(IN) for nonpointer dummy argument 'count='
+ call system_clock(count=i)
+ !ERROR: PROTECTED_TARGET pointer 'ia' or its subobject requires INTENT(IN) for nonpointer dummy argument 'get='
+ call random_seed(get=ia)
+ call random_seed(put=ia)
+ !ERROR: PROTECTED_TARGET pointer 'i' or its subobject requires INTENT(IN) for nonpointer dummy argument 'to='
+ call mvbits(0, 0, 1, i, 0)
+ call mvbits(i, 0, 1, ordinary_integer, 0)
+end
+
+subroutine c_interoperability
+ use iso_c_binding, only: c_f_pointer, c_null_ptr
+ integer, pointer :: ordinary
+ integer, pointer, protected_target :: p
+ call c_f_pointer(c_null_ptr, ordinary)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be associated with dummy argument 'fptr=' without PROTECTED_TARGET
+ call c_f_pointer(c_null_ptr, p)
+end
+
+subroutine defined_assignment_control(y)
+ use targets
+ type(t), intent(in) :: y
+ type(t) :: ordinary
+ ordinary = 3
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'a=' is not definable
+ !BECAUSE: 'y' is an INTENT(IN) dummy argument
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'y' is an INTENT(IN) dummy argument
+ y = 3
+end
+
+subroutine characteristic_matching
+ use targets
+ procedure(readonly_in), pointer :: proc
+ procedure(get), pointer :: func
+ interface
+ function ordinary_result() result(p)
+ integer, pointer :: p
+ end
+ end interface
+ procedure(pointer_in), pointer :: ordinary_proc
+ procedure(ordinary_result), pointer :: ordinary_func
+ proc => readonly_in
+ proc => pointer_in
+ func => get
+ func => ordinary_result
+ ordinary_proc => readonly_in
+ ordinary_func => get
+ call take_readonly(pointer_in)
+ call take_ordinary(readonly_in)
+ call take_readonly_function(ordinary_result)
+ call take_ordinary_function(get)
+contains
+ subroutine take_readonly(sub)
+ procedure(readonly_in) :: sub
+ end
+ subroutine take_ordinary(sub)
+ procedure(pointer_in) :: sub
+ end
+ subroutine take_readonly_function(f)
+ procedure(get) :: f
+ end
+ subroutine take_ordinary_function(f)
+ procedure(ordinary_result) :: f
+ end
+end
+
+module separate_characteristics
+ interface
+ module subroutine ordinary_body(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end
+ module subroutine readonly_body(p)
+ integer, pointer, intent(in) :: p
+ end
+ module function ordinary_body_result() result(p)
+ integer, pointer, protected_target :: p
+ end
+ module function readonly_body_result() result(p)
+ integer, pointer :: p
+ end
+ module subroutine dummy_procedures(readonly, ordinary, readonly_result, ordinary_result)
+ interface
+ subroutine readonly(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end
+ subroutine ordinary(p)
+ integer, pointer, intent(in) :: p
+ end
+ function readonly_result() result(p)
+ integer, pointer, protected_target :: p
+ end
+ function ordinary_result() result(p)
+ integer, pointer :: p
+ end
+ end interface
+ end
+ module subroutine optional_mismatch(p)
+ integer, pointer, optional, intent(in) :: p
+ end
+ end interface
+end
+
+submodule(separate_characteristics) separate_bodies
+contains
+ module subroutine ordinary_body(p)
+ integer, pointer, intent(in) :: p
+ end
+ module subroutine readonly_body(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end
+ module function ordinary_body_result() result(p)
+ integer, pointer :: p
+ nullify(p)
+ end
+ module function readonly_body_result() result(p)
+ integer, pointer, protected_target :: p
+ nullify(p)
+ end
+ module subroutine dummy_procedures(readonly, ordinary, readonly_result, ordinary_result)
+ interface
+ subroutine readonly(p)
+ integer, pointer, intent(in) :: p
+ end
+ subroutine ordinary(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end
+ function readonly_result() result(p)
+ integer, pointer :: p
+ end
+ function ordinary_result() result(p)
+ integer, pointer, protected_target :: p
+ end
+ end interface
+ end
+ module subroutine optional_mismatch(p)
+ !ERROR: Dummy argument 'p' does not have the OPTIONAL attribute; the corresponding argument in the interface body does
+ integer, pointer, protected_target, intent(in) :: p
+ end
+end
+
+module overriding_characteristics
+ type base
+ contains
+ procedure, nopass :: read => readonly
+ procedure, nopass :: write => ordinary
+ procedure, nopass :: read_result => readonly_result
+ procedure, nopass :: write_result => ordinary_result
+ end type
+ type, extends(base) :: extended
+ contains
+ procedure, nopass :: read => ordinary
+ procedure, nopass :: write => readonly
+ procedure, nopass :: read_result => ordinary_result
+ procedure, nopass :: write_result => readonly_result
+ end type
+contains
+ subroutine readonly(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end
+ subroutine ordinary(p)
+ integer, pointer, intent(in) :: p
+ end
+ function readonly_result() result(p)
+ integer, pointer, protected_target :: p
+ nullify(p)
+ end
+ function ordinary_result() result(p)
+ integer, pointer :: p
+ nullify(p)
+ end
+end
More information about the flang-commits
mailing list