[flang-commits] [flang] [flang] Support the Fortran 2028 PROTECTED_TARGET attribute (PR #230946)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Sun Oct 11 03:47:42 PDT 2026
https://github.com/Saieiei created https://github.com/llvm/llvm-project/pull/230946
Add parsing, module file and semantic support for the Fortran 2028
PROTECTED_TARGET attribute, with tests and a release note.
Assisted-by: GitHub Copilot
>From ce3a5d977a847add77f1ad6e8afac5006fbd1e3f Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Sun, 11 Oct 2026 05:47:29 -0500
Subject: [PATCH] [flang] Support the Fortran 2028 PROTECTED_TARGET attribute
Add parsing, module file and semantic support for the Fortran 2028
PROTECTED_TARGET attribute, with tests and a release note.
Assisted-by: GitHub Copilot
---
flang/docs/ReleaseNotes.md | 11 +
flang/examples/FeatureList/FeatureList.cpp | 2 +
.../include/flang/Evaluate/characteristics.h | 12 +-
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 22 +-
flang/include/flang/Semantics/attr.h | 4 +-
flang/include/flang/Semantics/tools.h | 8 +
flang/lib/Evaluate/characteristics.cpp | 19 +-
flang/lib/Parser/Fortran-parsers.cpp | 10 +-
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 | 39 ++
flang/lib/Semantics/check-coarray.cpp | 30 ++
flang/lib/Semantics/check-declarations.cpp | 31 +-
flang/lib/Semantics/check-io.cpp | 7 +
flang/lib/Semantics/check-omp-structure.cpp | 14 +-
flang/lib/Semantics/definable.cpp | 10 +
flang/lib/Semantics/pointer-assignment.cpp | 57 ++-
flang/lib/Semantics/resolve-names.cpp | 14 +-
flang/lib/Semantics/tools.cpp | 57 +++
.../Lower/HLFIR/allocatables-and-pointers.f90 | 14 +
flang/test/Parser/typeof-classof-attrs.f90 | 14 +
.../OpenMP/declare-variant-restriction.f90 | 49 +++
flang/test/Semantics/OpenMP/lastprivate01.f90 | 38 ++
.../private-is-pointer-allocatable-check.f90 | 10 +
flang/test/Semantics/allocate13.f90 | 68 ++++
flang/test/Semantics/assign02.f90 | 143 ++++++++
flang/test/Semantics/assign03.f90 | 109 ++++++
flang/test/Semantics/call07.f90 | 336 ++++++++++++++++++
flang/test/Semantics/definable01.f90 | 134 ++++++-
flang/test/Semantics/event01b.f90 | 10 +
flang/test/Semantics/form_team01.f90 | 10 +
flang/test/Semantics/lockstmt01.f90 | 11 +
flang/test/Semantics/modfile29.f90 | 3 +
flang/test/Semantics/modfile87.f90 | 158 ++++++++
flang/test/Semantics/resolve42.f90 | 29 ++
flang/test/Semantics/resolve81.f90 | 46 +++
flang/test/Semantics/resolve94.f90 | 37 ++
flang/test/Semantics/structconst09.f90 | 48 +++
41 files changed, 1601 insertions(+), 28 deletions(-)
diff --git a/flang/docs/ReleaseNotes.md b/flang/docs/ReleaseNotes.md
index 609ca499da396..03199f6853799 100644
--- a/flang/docs/ReleaseNotes.md
+++ b/flang/docs/ReleaseNotes.md
@@ -29,6 +29,17 @@ page](https://llvm.org/releases/).
## Major New Features
+- Added frontend support for the Fortran 2028 draft `PROTECTED_TARGET`
+ attribute (J3/26-007r1 8.5.16) on data pointers, including components and
+ function results. The attribute is kept in module files. Flang reports the
+ constraints of 8.5.16 as errors where the pointer or a subobject of it
+ appears: for example, the target cannot be defined through the pointer,
+ `ALLOCATE` of the pointer needs `SOURCE=`, and the pointer cannot be
+ deallocated.
+ Where C864 conflicts with 8.5.16 NOTE 1, Flang follows C864: if `x` is a
+ use-associated nonpointer `PROTECTED` object, `p => x` and initialization
+ with `x` are errors for a `PROTECTED_TARGET` pointer `p`.
+
## Bug Fixes
- Fixed `fir::getTypeSizeAndAlignment` returning the wrong allocation size for
diff --git a/flang/examples/FeatureList/FeatureList.cpp b/flang/examples/FeatureList/FeatureList.cpp
index c5bcff5ac6088..0955f08de29ba 100644
--- a/flang/examples/FeatureList/FeatureList.cpp
+++ b/flang/examples/FeatureList/FeatureList.cpp
@@ -605,6 +605,8 @@ struct NodeVisitor {
READ_FEATURE(ProgramUnit)
READ_FEATURE(Protected)
READ_FEATURE(ProtectedStmt)
+ READ_FEATURE(ProtectedTarget)
+ READ_FEATURE(ProtectedTargetStmt)
READ_FEATURE(ReadStmt)
READ_FEATURE(RealLiteralConstant)
READ_FEATURE(RealLiteralConstant::Real)
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 1ba0bf693c763..8c6051a850448 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -233,11 +233,15 @@ class TypeAndShape {
// 15.3.2.2
struct DummyDataObject {
+ // ProtectedTarget is kept for call checking, but it is not a characteristic
+ // in F'2028 (J3/26-007r1 15.3.2.2), so comparisons ignore it.
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);
+ 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,9 @@ using DummyArguments = std::vector<DummyArgument>;
// 15.3.3
struct FunctionResult {
- ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous)
+ // ProtectedTarget is not a characteristic in F'2028 (J3/26-007r1 15.3.3),
+ // so comparisons ignore it.
+ 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..f7d4977dfaaad 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
@@ -376,6 +377,7 @@ EMPTY_CLASS(ErrorRecovery);
// volatile-stmt | value-stmt | common-stmt | equivalence-stmt
// Extension: (Cray) based POINTER statement
// Extension: CUDA data attribute statement
+// F'2028: protected-target-stmt
struct OtherSpecificationStmt {
UNION_CLASS_BOILERPLATE(OtherSpecificationStmt);
std::variant<common::Indirection<AccessStmt>,
@@ -386,9 +388,10 @@ struct OtherSpecificationStmt {
common::Indirection<IntentStmt>, common::Indirection<IntrinsicStmt>,
common::Indirection<NamelistStmt>, common::Indirection<OptionalStmt>,
common::Indirection<PointerStmt>, common::Indirection<ProtectedStmt>,
- common::Indirection<SaveStmt>, common::Indirection<TargetStmt>,
- common::Indirection<ValueStmt>, common::Indirection<VolatileStmt>,
- common::Indirection<CommonStmt>, common::Indirection<EquivalenceStmt>,
+ common::Indirection<ProtectedTargetStmt>, common::Indirection<SaveStmt>,
+ common::Indirection<TargetStmt>, common::Indirection<ValueStmt>,
+ common::Indirection<VolatileStmt>, common::Indirection<CommonStmt>,
+ common::Indirection<EquivalenceStmt>,
common::Indirection<BasedPointerStmt>,
common::Indirection<CUDAAttributesStmt>>
u;
@@ -995,9 +998,11 @@ struct ComponentArraySpec {
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// F'2028: PROTECTED_TARGET
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE | UNIFIED
EMPTY_CLASS(Allocatable);
EMPTY_CLASS(Pointer);
+EMPTY_CLASS(ProtectedTarget);
EMPTY_CLASS(Contiguous);
// CUDA-data-attr [( IMPLICIT )]
// The (IMPLICIT) qualifier marks an attribute that the compiler applied on the
@@ -1013,7 +1018,8 @@ struct CUDADataAttrSpec {
struct ComponentAttrSpec {
UNION_CLASS_BOILERPLATE(ComponentAttrSpec);
std::variant<AccessSpec, Allocatable, CoarraySpec, Contiguous,
- ComponentArraySpec, Pointer, CUDADataAttrSpec, ErrorRecovery>
+ ComponentArraySpec, Pointer, ProtectedTarget, CUDADataAttrSpec,
+ ErrorRecovery>
u;
};
@@ -1406,6 +1412,7 @@ WRAPPER_CLASS(RankClause, ScalarIntConstantExpr);
// DIMENSION ( array-spec ) | EXTERNAL | INTENT ( intent-spec ) |
// INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
// PROTECTED | RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
+// F'2028: PROTECTED_TARGET
// VALUE | VOLATILE |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE
EMPTY_CLASS(Asynchronous);
@@ -1422,8 +1429,8 @@ struct AttrSpec {
UNION_CLASS_BOILERPLATE(AttrSpec);
std::variant<AccessSpec, Allocatable, Asynchronous, CoarraySpec, Contiguous,
ArraySpec, External, IntentSpec, Intrinsic, LanguageBindingSpec, Optional,
- Parameter, Pointer, Protected, RankClause, Save, Target, Value, Volatile,
- CUDADataAttrSpec>
+ Parameter, Pointer, Protected, ProtectedTarget, RankClause, Save, Target,
+ Value, Volatile, CUDADataAttrSpec>
u;
};
@@ -1616,6 +1623,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..e7f6f7dd33ff1 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -178,6 +178,14 @@ inline bool IsIntentOut(const Symbol &symbol) {
inline bool IsProtected(const Symbol &symbol) {
return symbol.attrs().test(Attr::PROTECTED);
}
+// Find the pointer protecting the referenced target. A pointer definition
+// concerns the containing object instead of the rightmost pointer's target.
+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..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..88adee8262e59 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -469,6 +469,7 @@ TYPE_PARSER(construct<DataComponentDefStmt>(declarationTypeSpec,
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// F'2028: PROTECTED_TARGET
// CUDA-data-attr
TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(allocatable) ||
@@ -476,6 +477,7 @@ TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(contiguous) ||
construct<ComponentAttrSpec>("DIMENSION" >> componentArraySpec) ||
construct<ComponentAttrSpec>(pointer) ||
+ construct<ComponentAttrSpec>(protectedTargetAttr) ||
extension<LanguageFeature::CUDA>(
construct<ComponentAttrSpec>(Parser<CUDADataAttrSpec>{})) ||
construct<ComponentAttrSpec>(recovery(
@@ -743,6 +745,7 @@ TYPE_PARSER(
// DIMENSION ( array-spec ) | EXTERNAL | INTENT ( intent-spec ) |
// INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
// PROTECTED | RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
+// F'2028: PROTECTED_TARGET
// VALUE | VOLATILE |
// CUDA-data-attr
TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
@@ -756,7 +759,8 @@ TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
construct<AttrSpec>(construct<Intrinsic>("INTRINSIC"_tok)) ||
construct<AttrSpec>(languageBindingSpec) || construct<AttrSpec>(optional) ||
construct<AttrSpec>(construct<Parameter>("PARAMETER"_tok)) ||
- construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedAttr) ||
+ construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedTargetAttr) ||
+ construct<AttrSpec>(protectedAttr) ||
construct<AttrSpec>("RANK" >>
construct<RankClause>(parenthesized(scalarIntConstantExpr))) ||
construct<AttrSpec>(save) ||
@@ -1050,6 +1054,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..adf32807ac3e2 100644
--- a/flang/lib/Parser/misc-parsers.h
+++ b/flang/lib/Parser/misc-parsers.h
@@ -49,6 +49,8 @@ constexpr auto allocatable{construct<Allocatable>("ALLOCATABLE"_tok)};
constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
+constexpr auto protectedTargetAttr{
+ construct<ProtectedTarget>("PROTECTED_TARGET"_tok)};
constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
constexpr auto save{construct<Save>("SAVE"_tok)};
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 08283a8be35e3..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..e105cb48bf242 100644
--- a/flang/lib/Parser/unparse.cpp
+++ b/flang/lib/Parser/unparse.cpp
@@ -315,6 +315,7 @@ class UnparseVisitor {
Word("ALLOCATABLE");
}
void Unparse(const Pointer &) { Word("POINTER"); }
+ void Unparse(const ProtectedTarget &) { Word("PROTECTED_TARGET"); }
void Unparse(const Contiguous &) { Word("CONTIGUOUS"); }
void Before(const ComponentAttrSpec &x) {
common::visit(common::visitors{
@@ -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..bfd4d77b4eaa0 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -683,6 +683,12 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
return false;
}
context.CheckIndexVarRedefine(name_);
+ if (ultimate_->attrs().test(Attr::PROTECTED_TARGET) &&
+ !allocateInfo_.gotSource) { // F'2028 C869
+ context.Say(name_.source,
+ "A PROTECTED_TARGET allocate-object must have SOURCE= in its ALLOCATE statement"_err_en_US);
+ return false;
+ }
const Scope &subpScope{
GetProgramUnitContaining(context.FindScope(name_.source))};
if (allocateObject_.typedExpr && allocateObject_.typedExpr->v) {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index feabf0cd33bf0..02773cd035ada 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -67,6 +67,13 @@ 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)}) { // F'2028 C873
+ evaluate::AttachDeclaration(
+ messages.Say(arg.sourceLocation(),
+ "PROTECTED_TARGET actual argument requires an explicit interface"_err_en_US),
+ *pointer);
+ return;
+ }
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
@@ -399,6 +406,38 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
bool dummyIsPointer{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
+ // F'2028 C872, C874: like definability, these are checked only after a
+ // specific procedure has been selected, so they do not affect generic
+ // resolution.
+ if (scope) {
+ const Symbol *protectedTarget{FindProtectedTarget(actual)};
+ if (!protectedTarget && dummyIsPointer &&
+ evaluate::IsObjectPointer(actual)) {
+ protectedTarget = FindProtectedTarget(actual, true);
+ }
+ if (protectedTarget) {
+ if (dummyIsPointer &&
+ !dummy.attrs.test(
+ characteristics::DummyDataObject::Attr::ProtectedTarget)) {
+ evaluate::AttachDeclaration(
+ messages.Say(
+ "PROTECTED_TARGET actual argument requires PROTECTED_TARGET for pointer %s"_err_en_US,
+ dummyName),
+ *protectedTarget);
+ return;
+ } else if (!dummyIsPointer && dummy.intent != common::Intent::In &&
+ !(intrinsic && intrinsic->name == "null")) {
+ // NULL's MOLD= has INTENT(IN) like other intrinsic dummy arguments,
+ // but is characterized without it.
+ evaluate::AttachDeclaration(
+ messages.Say(
+ "PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer %s"_err_en_US,
+ dummyName),
+ *protectedTarget);
+ return;
+ }
+ }
+ }
bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer};
allowActualArgumentConversions &= !dummyIsAllocatableOrPointer;
bool typesCompatibleWithIgnoreTKR{
diff --git a/flang/lib/Semantics/check-coarray.cpp b/flang/lib/Semantics/check-coarray.cpp
index 00b97162ff0d4..0f413558ac395 100644
--- a/flang/lib/Semantics/check-coarray.cpp
+++ b/flang/lib/Semantics/check-coarray.cpp
@@ -97,6 +97,22 @@ class ChangeTeamBodyEnforce {
parser::CharBlock changeTeamSourcePosition_;
};
+template <typename T>
+static void CheckProtectedTargetDefinition(
+ SemanticsContext &context, const T &x, const char *what) {
+ if (const auto *expr{GetExpr(context, x)};
+ expr && FindProtectedTarget(*expr)) {
+ auto at{parser::FindSourceLocation(x)};
+ if (auto whyNot{WhyNotDefinable(at, context.FindScope(at),
+ {DefinabilityFlag::DoNotNoteDefinition,
+ DefinabilityFlag::AllowEventLockOrNotifyType},
+ *expr)}) {
+ context.Say(at, "%s variable is not definable"_err_en_US, what)
+ .Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
+ }
+ }
+}
+
template <typename T>
static void CheckTeamType(
SemanticsContext &context, const T &x, bool mustBeVariable = false) {
@@ -108,6 +124,8 @@ static void CheckTeamType(
} else if (mustBeVariable && !IsVariable(*expr)) {
context.Say(parser::FindSourceLocation(x),
"Team must be a variable in this context"_err_en_US);
+ } else if (mustBeVariable) {
+ CheckProtectedTargetDefinition(context, x, "TEAM");
}
}
}
@@ -177,6 +195,8 @@ static void CheckEventVariable(
if (!IsEventType(evaluate::GetDerivedTypeSpec(expr->GetType()))) { // C1176
context.Say(parser::FindSourceLocation(eventVar),
"The event-variable must be of type EVENT_TYPE from module ISO_FORTRAN_ENV"_err_en_US);
+ } else {
+ CheckProtectedTargetDefinition(context, eventVar, "EVENT");
}
}
}
@@ -363,6 +383,10 @@ void CoarrayChecker::Leave(const parser::LockStmt &x) {
"Multiple ACQUIRED_LOCK specifiers"_err_en_US);
} else {
gotAcquired = true;
+ CheckProtectedTargetDefinition(context_,
+ std::get<parser::Scalar<parser::Logical<parser::Variable>>>(
+ lockStat.u),
+ "ACQUIRED_LOCK");
}
}
}
@@ -383,6 +407,12 @@ void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(
&imageSelectorSpec.u)}) {
CheckTeamStat(context_, *stat);
+ CheckProtectedTargetDefinition(context_, stat->v, "Image selector STAT");
+ } else if (const auto *notify{
+ std::get_if<parser::ImageSelectorSpec::Notify>(
+ &imageSelectorSpec.u)}) {
+ CheckProtectedTargetDefinition(
+ context_, notify->v, "Image selector NOTIFY");
}
}
}
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 2abefd381850a..09ff00609f507 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -333,6 +333,12 @@ void CheckHelper::Check(const Symbol &symbol) {
return; // following checks do not apply
}
+ if (symbol.attrs().test(Attr::PROTECTED_TARGET) &&
+ !IsObjectPointer(&symbol)) { // F'2028 C781, C8109
+ messages_.Say(
+ "An entity with PROTECTED_TARGET must be a data pointer"_err_en_US);
+ }
+
if (symbol.attrs().test(Attr::PROTECTED)) {
if (symbol.owner().kind() != Scope::Kind::Module) { // C854
messages_.Say(
@@ -529,6 +535,26 @@ void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
auto restorer{
messages_.SetLocation(location.empty() ? ref->name() : location)};
+ if (ref->attrs().test(Attr::PROTECTED_TARGET)) { // F'2028 C867
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "PROTECTED_TARGET pointer '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ } else if (!IsPointer(*ref)) {
+ // Treat physically contained pointer components as being in COMMON.
+ // A pointer's target is not part of the block's storage.
+ if (const Symbol *component{
+ FindUltimateComponent(*ref, [](const Symbol &x) {
+ return x.attrs().test(Attr::PROTECTED_TARGET);
+ })}) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "COMMON block /%s/ member '%s' has PROTECTED_TARGET component '%s'"_err_en_US,
+ symbol.name(), ref->name(), component->name()),
+ *component);
+ }
+ }
if (isBindCCommon && ref->has<ObjectEntityDetails>()) {
if (auto msgs{WhyNotInteroperableObject(*ref,
/*allowInteroperableType=*/false, /*forCommonBlock=*/true)};
@@ -4176,8 +4202,11 @@ void SubprogramMatchHelper::CheckDummyArg(const Symbol &symbol1,
void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
const Symbol &symbol2, const DummyDataObject &obj1,
const DummyDataObject &obj2) {
+ // PROTECTED_TARGET is not a characteristic (F'2028 15.3.2.2)
if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
- } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
+ } else if (!CheckSameAttrs(symbol1, symbol2,
+ obj1.attrs - DummyDataObject::Attr::ProtectedTarget,
+ obj2.attrs - DummyDataObject::Attr::ProtectedTarget)) {
} else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
Say(symbol1, symbol2,
"Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index bc9181592aeb5..df6a387de5d85 100644
--- a/flang/lib/Semantics/check-io.cpp
+++ b/flang/lib/Semantics/check-io.cpp
@@ -811,6 +811,13 @@ void IoChecker::Leave(const parser::InquireStmt &stmt) {
CheckForProhibitedSpecifier(IoSpecKind::File, IoSpecKind::Unit); // C1246
CheckForRequiredSpecifier(IoSpecKind::Id, IoSpecKind::Pending); // C1248
CheckForUselessIomsg();
+ } else {
+ const auto &var{std::get<parser::ScalarIntVariable>(
+ std::get<parser::InquireStmt::Iolength>(stmt.u).t)};
+ if (const auto *expr{GetExpr(context_, var)};
+ expr && FindProtectedTarget(*expr)) {
+ CheckForDefinableVariable(var, "IOLENGTH");
+ }
}
Done();
}
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 6193b297b62fb..1c882905a4e11 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -6184,8 +6184,18 @@ void OmpStructureChecker::CheckDefinableObjects(
if (!IsVariableListItem(*symbol)) {
continue;
}
- if (auto msg{WhyNotDefinable(source, context_.FindScope(source),
- DefinabilityFlags{}, *symbol)}) {
+ DefinabilityFlags flags;
+ if (clause == llvm::omp::Clause::OMPC_lastprivate && IsPointer(*symbol) &&
+ symbol->attrs().test(Attr::PROTECTED_TARGET)) {
+ // The original POINTER list item is updated by pointer assignment,
+ // which does not define its PROTECTED_TARGET target (F'2028 C866).
+ if (IsIntentIn(*symbol)) {
+ continue; // reported by CheckIntentInPointer()
+ }
+ flags.set(DefinabilityFlag::PointerDefinition);
+ }
+ if (auto msg{WhyNotDefinable(
+ source, context_.FindScope(source), flags, *symbol)}) {
context_
.Say(source,
"Variable '%s' on the %s clause is not definable"_err_en_US,
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index d6a654683001f..25aff8758bb05 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -270,6 +270,11 @@ static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
+ if (const Symbol *pointer{FindProtectedTarget(
+ original, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameSymbol(
+ at, "'%s' is a PROTECTED_TARGET pointer"_en_US, *pointer);
+ }
auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
/*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
if (!whyNotBase || !whyNotBase->IsFatal()) {
@@ -330,6 +335,11 @@ class DuplicatedSubscriptFinder
std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags,
const evaluate::Expr<evaluate::SomeType> &expr) {
+ if (const Symbol *pointer{FindProtectedTarget(
+ expr, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameSymbol(
+ at, "'%s' is a PROTECTED_TARGET pointer"_en_US, *pointer);
+ }
std::optional<parser::Message> portabilityWarning;
if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
if (evaluate::HasVectorSubscript(expr)) {
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..85015d9388e9f 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -22,6 +22,7 @@
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include "llvm/Support/raw_ostream.h"
+#include <algorithm>
#include <optional>
#include <string>
@@ -50,10 +51,15 @@ class PointerAssignmentChecker {
set_lhsType(TypeAndShape::Characterize(lhs, foldingContext_));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
+ // OpenMP data-sharing symbols are host-associated without attributes.
+ set_isProtectedTarget(
+ lhs.GetUltimate().attrs().test(Attr::PROTECTED_TARGET));
}
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_isContiguous(bool);
PointerAssignmentChecker &set_isVolatile(bool);
+ PointerAssignmentChecker &set_isProtectedTarget(bool);
+ PointerAssignmentChecker &set_isArgumentAssociation(bool);
PointerAssignmentChecker &set_isBoundsRemapping(bool);
PointerAssignmentChecker &set_isAssumedRank(bool);
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
@@ -92,6 +98,8 @@ class PointerAssignmentChecker {
bool characterizedProcedure_{false};
bool isContiguous_{false};
bool isVolatile_{false};
+ bool isProtectedTarget_{false};
+ bool isArgumentAssociation_{false};
bool isBoundsRemapping_{false};
bool isAssumedRank_{false};
bool isRHSPointerActualArgument_{false};
@@ -117,6 +125,18 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isProtectedTarget(
+ bool isProtectedTarget) {
+ isProtectedTarget_ = isProtectedTarget;
+ return *this;
+}
+
+PointerAssignmentChecker &PointerAssignmentChecker::set_isArgumentAssociation(
+ bool isArgumentAssociation) {
+ isArgumentAssociation_ = isArgumentAssociation;
+ return *this;
+}
+
PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
bool isBoundsRemapping) {
isBoundsRemapping_ = isBoundsRemapping;
@@ -198,6 +218,15 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
Say("A coindexed object may not be a pointer target"_err_en_US);
return false;
}
+ if (!isProtectedTarget_) {
+ if (const Symbol *pointer{FindProtectedTarget(rhs)}) {
+ evaluate::AttachDeclaration(
+ Say("A PROTECTED_TARGET target may not be associated with %s that is not PROTECTED_TARGET"_err_en_US,
+ description_),
+ *pointer);
+ return false;
+ }
+ }
if (!common::visit([&](const auto &x) { return Check(x); }, rhs.u)) {
return false;
}
@@ -243,9 +272,28 @@ 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 (isProtectedTarget_) {
+ // F'2028 C864 conflicts with 8.5.16 NOTE 1. Follow the constraint for
+ // data-targets and initial-data-targets, not argument association.
+ // Keep ordinary-pointer diagnostics unchanged.
+ if (auto dataRef{evaluate::ExtractDataRef(rhs, true, true)};
+ dataRef && !isArgumentAssociation_) {
+ auto symbols{evaluate::GetSymbolVector(*dataRef)};
+ if (!symbols.empty()) {
+ const Symbol &base{symbols.front()};
+ if (IsProtected(base.GetUltimate()) && IsUseAssociated(base, scope_) &&
+ std::none_of(symbols.begin(), symbols.end(),
+ [](const Symbol &x) { return IsPointer(x.GetUltimate()); })) {
+ evaluate::AttachDeclaration(
+ Say("A PROTECTED_TARGET pointer may not be associated with USE-associated PROTECTED target '%s'"_err_en_US,
+ base.name()),
+ base);
+ return false;
+ }
+ }
+ }
+ } else if (auto because{WhyNotDefinable(
+ foldingContext_.messages().at(), scope_, {}, rhs)}) {
if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
"Pointer target is not a definable variable"_warn_en_US)}) {
msg->Attach(std::move(because->set_severity(parser::Severity::Because)));
@@ -619,6 +667,9 @@ 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_isArgumentAssociation(true)
.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..891a54a40e097 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -299,6 +299,7 @@ class AttrsVisitor : public virtual BaseVisitor {
HANDLE_ATTR_CLASS(Parameter, PARAMETER)
HANDLE_ATTR_CLASS(Pointer, POINTER)
HANDLE_ATTR_CLASS(Protected, PROTECTED)
+ HANDLE_ATTR_CLASS(ProtectedTarget, PROTECTED_TARGET)
HANDLE_ATTR_CLASS(Save, SAVE)
HANDLE_ATTR_CLASS(Target, TARGET)
HANDLE_ATTR_CLASS(Value, VALUE)
@@ -1090,6 +1091,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool Pre(const parser::IntrinsicStmt &);
bool Pre(const parser::OptionalStmt &);
bool Pre(const parser::ProtectedStmt &);
+ bool Pre(const parser::ProtectedTargetStmt &);
bool Pre(const parser::ValueStmt &);
bool Pre(const parser::VolatileStmt &);
bool Pre(const parser::AllocatableStmt &) {
@@ -6763,6 +6765,9 @@ bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) {
bool DeclarationVisitor::Pre(const parser::ProtectedStmt &x) {
return HandleAttributeStmt(Attr::PROTECTED, x.v);
}
+bool DeclarationVisitor::Pre(const parser::ProtectedTargetStmt &x) {
+ return HandleAttributeStmt(Attr::PROTECTED_TARGET, x.v);
+}
bool DeclarationVisitor::Pre(const parser::ValueStmt &x) {
return CheckNotInBlock("VALUE") && // C1107
HandleAttributeStmt(Attr::VALUE, x.v);
@@ -6873,7 +6878,8 @@ Symbol &DeclarationVisitor::DeclareUnknownEntity(
ConvertToProcEntity(symbol);
} else if (symbol.attrs().HasAny(Attrs{Attr::ALLOCATABLE,
Attr::ASYNCHRONOUS, Attr::CONTIGUOUS, Attr::PARAMETER,
- Attr::SAVE, Attr::TARGET, Attr::VALUE, Attr::VOLATILE})) {
+ Attr::PROTECTED_TARGET, Attr::SAVE, Attr::TARGET,
+ Attr::VALUE, Attr::VOLATILE})) {
ConvertToObjectEntity(symbol);
}
if (attrs.test(Attr::BIND_C)) {
@@ -9334,7 +9340,8 @@ 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};
+ 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..5d81a31fb9ba4 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,62 @@
namespace Fortran::semantics {
+static const Symbol *FindProtectedTarget(
+ const SymbolVector &symbols, bool isPointerDefinition) {
+ // F'2028 9.4.2p5: a pointer component's target is not a subobject of its
+ // containing object. Its association status is, so skip only the rightmost
+ // pointer when checking a pointer definition.
+ bool isLast{true};
+ for (auto iter{symbols.rbegin()}; iter != symbols.rend(); ++iter) {
+ const Symbol &symbol{(**iter).GetUltimate()};
+ if (IsPointer(symbol)) {
+ if (!isLast || !isPointerDefinition) {
+ return symbol.attrs().test(Attr::PROTECTED_TARGET) ? &symbol : nullptr;
+ }
+ } else if (const auto *association{symbol.detailsIf<AssocEntityDetails>()};
+ association && association->expr() &&
+ evaluate::IsVariable(*association->expr())) {
+ return FindProtectedTarget(*association->expr());
+ }
+ isLast = false;
+ }
+ 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 *call{evaluate::UnwrapProcedureRef(expr)}) {
+ if (const Symbol *interface{call->proc().GetInterfaceSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*interface)};
+ result && result->attrs().test(Attr::PROTECTED_TARGET)) {
+ return result;
+ }
+ }
+ }
+ } else if (const auto *procedure{
+ std::get_if<evaluate::ProcedureDesignator>(&expr.u)}) {
+ if (const auto *component{procedure->GetComponent()}) {
+ return FindProtectedTarget(component->base());
+ }
+ }
+ 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/Lower/HLFIR/allocatables-and-pointers.f90 b/flang/test/Lower/HLFIR/allocatables-and-pointers.f90
index 7114fa8db2c8c..aee383ae6d0ea 100644
--- a/flang/test/Lower/HLFIR/allocatables-and-pointers.f90
+++ b/flang/test/Lower/HLFIR/allocatables-and-pointers.f90
@@ -154,3 +154,17 @@ subroutine elemental_expr(x)
! CHECK: %[[VAL_23:.*]] = arith.addi %[[VAL_22]], %[[VAL_3]] : i32
! CHECK: hlfir.yield_element %[[VAL_23]] : i32
! CHECK: }
+
+! A PROTECTED_TARGET pointer is lowered like any other pointer.
+subroutine passing_protected_target_pointer(x)
+ interface
+ subroutine takes_protected_target_pointer(y)
+ real, pointer, protected_target, intent(in) :: y(:)
+ end subroutine
+ end interface
+ real, pointer, protected_target :: x(:)
+ call takes_protected_target_pointer(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPpassing_protected_target_pointer(
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:[a-z0-9]*]] dummy_scope %{{[0-9]+}} arg {{[0-9]+}} uniq_name({{.*}}Ex") fortran_attrs<pointer>
+! CHECK: fir.call @_QPtakes_protected_target_pointer(%[[VAL_1]]#0) {{.*}} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> ()
diff --git a/flang/test/Parser/typeof-classof-attrs.f90 b/flang/test/Parser/typeof-classof-attrs.f90
index d1be75dad8682..250c3c7e79a97 100644
--- a/flang/test/Parser/typeof-classof-attrs.f90
+++ b/flang/test/Parser/typeof-classof-attrs.f90
@@ -1,4 +1,6 @@
! RUN: %flang_fc1 -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s > %t.f90
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %t.f90 2>&1 | FileCheck %s
! Test TYPEOF and CLASSOF with spaces and attributes.
program test_program
@@ -6,6 +8,8 @@ program test_program
TYPE :: matrix
INTEGER :: v
+ !CHECK: INTEGER, POINTER, PROTECTED_TARGET :: readonly
+ INTEGER, POINTER, PROTECTED_TARGET :: readonly
END TYPE
TYPE(matrix) :: MAT
@@ -19,4 +23,14 @@ 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 :: tmat_readonly
+ TYPEOF(MAT), POINTER, PROTECTED_TARGET :: TMAT_READONLY
+ !CHECK: CLASSOF(mat), PROTECTED_TARGET, POINTER :: cmat_readonly
+ CLASSOF(MAT), PROTECTED_TARGET, POINTER :: CMAT_READONLY
+ INTEGER, POINTER :: p1, p2, p3
+ !CHECK: PROTECTED_TARGET :: p1, p2
+ PROTECTED_TARGET p1, p2
+ !CHECK: PROTECTED_TARGET :: p3
+ PROTECTED_TARGET :: p3
end program
diff --git a/flang/test/Semantics/OpenMP/declare-variant-restriction.f90 b/flang/test/Semantics/OpenMP/declare-variant-restriction.f90
index d3e67e2dc123c..37e06a1648c6a 100644
--- a/flang/test/Semantics/OpenMP/declare-variant-restriction.f90
+++ b/flang/test/Semantics/OpenMP/declare-variant-restriction.f90
@@ -182,3 +182,52 @@ subroutine p3
!$omp declare variant (p1) match (user={condition(.false.)})
end subroutine
end module
+
+! PROTECTED_TARGET is not a procedure characteristic.
+subroutine protected_target_variant_dummy
+ !$omp declare variant (ordinary:protected) match (user={condition(.true.)})
+contains
+ subroutine ordinary(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ subroutine protected(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+end subroutine
+
+subroutine ordinary_variant_dummy
+ !$omp declare variant (protected:ordinary) match (user={condition(.true.)})
+contains
+ subroutine ordinary(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ subroutine protected(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+end subroutine
+
+subroutine protected_target_variant_result
+ !$omp declare variant (ordinary:protected) match (user={condition(.true.)})
+contains
+ function ordinary() result(r)
+ integer, pointer :: r
+ r => null()
+ end function
+ function protected() result(r)
+ integer, pointer, protected_target :: r
+ r => null()
+ end function
+end subroutine
+
+subroutine ordinary_variant_result
+ !$omp declare variant (protected:ordinary) match (user={condition(.true.)})
+contains
+ function ordinary() result(r)
+ integer, pointer :: r
+ r => null()
+ end function
+ function protected() result(r)
+ integer, pointer, protected_target :: r
+ r => null()
+ end function
+end subroutine
diff --git a/flang/test/Semantics/OpenMP/lastprivate01.f90 b/flang/test/Semantics/OpenMP/lastprivate01.f90
index 4248a34e702c7..df43a8b07d591 100644
--- a/flang/test/Semantics/OpenMP/lastprivate01.f90
+++ b/flang/test/Semantics/OpenMP/lastprivate01.f90
@@ -5,6 +5,9 @@
module protected_var
integer, protected :: p
+ integer, protected, target :: pt
+ integer, pointer, protected_target :: ptp
+ integer, pointer, protected, protected_target :: pptp
end module protected_var
program omp_lastprivate
@@ -30,6 +33,23 @@ program omp_lastprivate
end do
!$omp end parallel do
+ ! A POINTER list item is updated by pointer assignment.
+ !$omp parallel do lastprivate(ptp)
+ do i = 1, 10
+ ptp => pptp
+ !ERROR: A PROTECTED_TARGET pointer may not be associated with USE-associated PROTECTED target 'pt'
+ ptp => pt
+ end do
+ !$omp end parallel do
+
+ !ERROR: Variable 'pptp' on the LASTPRIVATE clause is not definable
+ !BECAUSE: 'pptp' is protected in this scope
+ !$omp parallel do lastprivate(pptp)
+ do i = 1, 10
+ c(i) = a(i) + b(i) + k
+ end do
+ !$omp end parallel do
+
call omp_lastprivate_sb(i)
print *, c
@@ -54,3 +74,21 @@ subroutine omp_lastprivate_sb(m)
print *, c
end subroutine omp_lastprivate_sb
+
+subroutine omp_lastprivate_protected_target(ip)
+ integer, pointer, protected_target, intent(in) :: ip
+ integer, pointer, protected_target :: np
+ integer :: i
+
+ !$omp parallel do lastprivate(np)
+ do i = 1, 10
+ np => ip
+ end do
+ !$omp end parallel do
+
+ !ERROR: Pointer 'ip' with the INTENT(IN) attribute may not appear in a LASTPRIVATE clause
+ !$omp parallel do lastprivate(ip)
+ do i = 1, 10
+ end do
+ !$omp end parallel do
+end subroutine omp_lastprivate_protected_target
diff --git a/flang/test/Semantics/OpenMP/private-is-pointer-allocatable-check.f90 b/flang/test/Semantics/OpenMP/private-is-pointer-allocatable-check.f90
index 7b3915d9a1104..398ac74def10c 100644
--- a/flang/test/Semantics/OpenMP/private-is-pointer-allocatable-check.f90
+++ b/flang/test/Semantics/OpenMP/private-is-pointer-allocatable-check.f90
@@ -16,3 +16,13 @@ subroutine s
endif
!$omp end parallel
end subroutine
+
+subroutine protected_target
+ integer, pointer, protected_target :: p, q
+ integer, target :: t
+
+ q => t
+ !$omp parallel private(p) firstprivate(q)
+ p=>q
+ !$omp end parallel
+end subroutine
diff --git a/flang/test/Semantics/allocate13.f90 b/flang/test/Semantics/allocate13.f90
index 27097ba85e67b..b644595d71c83 100644
--- a/flang/test/Semantics/allocate13.f90
+++ b/flang/test/Semantics/allocate13.f90
@@ -144,6 +144,74 @@ subroutine C948_a()
allocate(whatever[*],SOURCE=nokt5src)
end subroutine
+module protected_target_allocation
+ type node
+ integer :: value = 1
+ integer, pointer, protected_target :: readonly
+ integer, pointer :: link
+ integer, allocatable :: allocatable
+ type(node), pointer :: next
+ end type
+contains
+ subroutine allocation(p, pin, object, source)
+ integer, pointer, protected_target :: p
+ integer, pointer, protected_target :: array(:)
+ integer, pointer, protected_target, intent(in) :: pin
+ type(node), pointer, protected_target :: object
+ type(node) :: source
+ type(node), pointer, protected_target :: initialized
+ integer, pointer :: ordinary
+ integer, pointer, protected_target :: stat
+ character(40), pointer, protected_target :: message
+ !ERROR: A PROTECTED_TARGET allocate-object must have SOURCE= in its ALLOCATE statement
+ allocate(p)
+ !ERROR: A PROTECTED_TARGET allocate-object must have SOURCE= in its ALLOCATE statement
+ allocate(p, mold=1)
+ !ERROR: A PROTECTED_TARGET allocate-object must have SOURCE= in its ALLOCATE statement
+ allocate(integer :: p)
+ !ERROR: A PROTECTED_TARGET allocate-object must have SOURCE= in its ALLOCATE statement
+ allocate(initialized)
+ allocate(p, source=1)
+ !ERROR: A PROTECTED_TARGET allocate-object must have SOURCE= in its ALLOCATE statement
+ allocate(array(2))
+ allocate(array(2), source=1)
+ allocate(array, source=[1,2])
+ allocate(initialized, source=source)
+ allocate(ordinary, source=p)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'pin' is an INTENT(IN) dummy argument
+ allocate(pin, source=1)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'object' is a PROTECTED_TARGET pointer
+ allocate(object%link, source=1)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'object' is a PROTECTED_TARGET pointer
+ allocate(object%allocatable, source=1)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'object' is a PROTECTED_TARGET pointer
+ allocate(object%readonly, source=1)
+ allocate(object%next%readonly, source=1)
+ allocate(object%next%link)
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ deallocate(p)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'object' is a PROTECTED_TARGET pointer
+ deallocate(object%link)
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'readonly' is a PROTECTED_TARGET pointer
+ deallocate(object%next%readonly)
+ deallocate(object%next%link)
+ !ERROR: STAT variable 'stat' is not definable
+ !BECAUSE: 'stat' is a PROTECTED_TARGET pointer
+ allocate(ordinary, stat=stat)
+ !ERROR: ERRMSG variable 'message' is not definable
+ !BECAUSE: 'message' is a PROTECTED_TARGET pointer
+ deallocate(ordinary, errmsg=message)
+ nullify(p, initialized)
+ end subroutine
+end module
+
subroutine C948_b()
use not_iso_fortran_env !type restriction do not apply
diff --git a/flang/test/Semantics/assign02.f90 b/flang/test/Semantics/assign02.f90
index c4470789476ad..f5de7f3e62f67 100644
--- a/flang/test/Semantics/assign02.f90
+++ b/flang/test/Semantics/assign02.f90
@@ -250,3 +250,146 @@ subroutine s2
p => z
end associate
end
+
+module protected_target_assignment
+ type node
+ integer :: value, array(3)
+ character(6) :: text
+ integer, pointer :: link
+ type(node), pointer :: next
+ procedure(callback), pointer, nopass :: action
+ end type
+ integer, target, protected :: protected_value
+ integer, pointer, protected :: protected_pointer
+contains
+ subroutine assignments
+ type(node), target :: object
+ type(node), pointer, protected_target :: p, keep
+ type(node), pointer :: ordinary
+ integer, target :: values(3)
+ integer, pointer :: scalar, array(:)
+ integer, pointer, protected_target :: readonly(:), index
+ character(:), pointer :: chars
+ character(:), pointer, protected_target :: readonly_chars
+ complex, target :: z
+ complex, pointer, protected_target :: readonly_z
+ real, pointer :: realpart
+
+ p => object
+ keep => p
+ ordinary => object
+ keep => ordinary
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'ordinary' that is not PROTECTED_TARGET
+ ordinary => p
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'scalar' that is not PROTECTED_TARGET
+ scalar => p%value
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'array' that is not PROTECTED_TARGET
+ array => p%array(1:2)
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'chars' that is not PROTECTED_TARGET
+ chars => p%text(2:4)
+ readonly => p%array
+ readonly_chars => p%text(2:4)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ p%value = 1
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ p%link => values(1)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ p%action => callback
+ !ERROR: 'action' may not appear in NULLIFY
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ nullify(p%action)
+ !ERROR: 'next' may not appear in NULLIFY
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ nullify(p%next)
+
+ ! Targets of ordinary pointer components are not subobjects of p's target.
+ scalar => p%link
+ p%link = 1
+ p%next%value = 1
+ p%next%next => object
+ p%next%action => callback
+ nullify(p%next%next)
+ associate(a => p%array)
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'array' that is not PROTECTED_TARGET
+ array => a
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ a(1) = 1
+ end associate
+ associate(a => p%next)
+ a%value = 1
+ end associate
+ readonly_z => z
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'realpart' that is not PROTECTED_TARGET
+ realpart => readonly_z%re
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'readonly_z' is a PROTECTED_TARGET pointer
+ readonly_z%im = 1
+ readonly => values
+ index => values(1)
+ scalar => values(index)
+ array => values(index:)
+ values = 2
+ nullify(p, keep, readonly, index, readonly_chars, readonly_z)
+ end subroutine
+ subroutine select_type_target(p)
+ class(node), pointer, protected_target :: p
+ select type(a => p)
+ type is(node)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ a%value = 1
+ a%link = 1
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ a%next => null()
+ end select
+ end subroutine
+ subroutine intent_in_pointer(p)
+ integer, pointer, protected_target, intent(in) :: p
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ p = 1
+ !ERROR: 'p' may not appear in NULLIFY
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ nullify(p)
+ end subroutine
+ subroutine ordinary_intent_in_pointer(p)
+ integer, pointer, intent(in) :: p
+ p = 1
+ end subroutine
+ subroutine owner
+ integer, pointer, protected_target :: p
+ p => protected_value
+ nullify(p)
+ end subroutine
+ subroutine callback
+ end subroutine
+end module
+
+subroutine protected_target_use_association
+ use protected_target_assignment, only: protected_value, protected_pointer
+ type box
+ integer, pointer, protected_target :: c
+ end type
+ integer, pointer, protected_target :: p
+ integer, pointer :: ordinary
+ type(box) :: b
+ ! Follow J3/26-007r1 C864 rather than the conflicting 8.5.16 NOTE 1.
+ !ERROR: A PROTECTED_TARGET pointer may not be associated with USE-associated PROTECTED target 'protected_value'
+ integer, pointer, protected_target :: initialized => protected_value
+ ordinary => protected_value
+ !ERROR: A PROTECTED_TARGET pointer may not be associated with USE-associated PROTECTED target 'protected_value'
+ p => protected_value
+ !ERROR: A PROTECTED_TARGET pointer may not be associated with USE-associated PROTECTED target 'protected_value'
+ b = box(protected_value)
+ p => protected_pointer
+ b = box(protected_pointer)
+ ordinary => protected_pointer
+ !ERROR: 'protected_pointer' may not appear in NULLIFY
+ !BECAUSE: 'protected_pointer' is protected in this scope
+ nullify(protected_pointer)
+end subroutine
diff --git a/flang/test/Semantics/assign03.f90 b/flang/test/Semantics/assign03.f90
index d8e7f14238f92..4f5fd7fd23613 100644
--- a/flang/test/Semantics/assign03.f90
+++ b/flang/test/Semantics/assign03.f90
@@ -335,3 +335,112 @@ subroutine s15
p=>sin ! ok
end
end
+
+module protected_target_procedure_characteristics
+ ! J3/26-007r1 omits PROTECTED_TARGET from the characteristics of dummy data
+ ! objects and function results (15.3.2.2, 15.3.3).
+ integer, target :: value
+ type ordinary_base
+ contains
+ procedure, nopass :: result => ordinary_result
+ procedure, nopass :: consume => ordinary_dummy
+ end type
+ type protected_base
+ contains
+ procedure, nopass :: result => protected_result
+ procedure, nopass :: consume => protected_dummy
+ end type
+ type, extends(ordinary_base) :: ordinary_overrides
+ contains
+ procedure, nopass :: result => protected_result
+ procedure, nopass :: consume => protected_dummy
+ end type
+ type, extends(protected_base) :: protected_overrides
+ contains
+ procedure, nopass :: result => ordinary_result
+ procedure, nopass :: consume => ordinary_dummy
+ end type
+contains
+ function ordinary_result() result(r)
+ integer, pointer :: r
+ r => value
+ end function
+ function protected_result() result(r)
+ integer, pointer, protected_target :: r
+ r => value
+ end function
+ subroutine ordinary_dummy(p)
+ integer, pointer, intent(in) :: p
+ end subroutine
+ subroutine protected_dummy(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end subroutine
+ subroutine ordinary_callback_result(f)
+ procedure(ordinary_result) :: f
+ end subroutine
+ subroutine protected_callback_result(f)
+ procedure(protected_result) :: f
+ end subroutine
+ subroutine ordinary_callback_dummy(s)
+ procedure(ordinary_dummy) :: s
+ end subroutine
+ subroutine protected_callback_dummy(s)
+ procedure(protected_dummy) :: s
+ end subroutine
+ subroutine ordinary_nested(f)
+ procedure(ordinary_callback_result) :: f
+ end subroutine
+ subroutine protected_nested(f)
+ procedure(protected_callback_result) :: f
+ end subroutine
+ function ordinary_factory() result(f)
+ procedure(ordinary_result), pointer :: f
+ f => ordinary_result
+ end function
+ function protected_factory() result(f)
+ procedure(protected_result), pointer :: f
+ f => ordinary_result
+ end function
+ subroutine compare
+ procedure(ordinary_result), pointer :: ordinary_function
+ procedure(protected_result), pointer :: protected_function
+ procedure(ordinary_dummy), pointer :: ordinary_subroutine
+ procedure(protected_dummy), pointer :: protected_subroutine
+ procedure(protected_result), pointer :: protected_initial => ordinary_result
+ procedure(ordinary_result), pointer :: ordinary_initial => protected_result
+ integer, pointer, protected_target :: keep
+ integer, pointer :: ordinary
+ ordinary_function => ordinary_result
+ protected_function => protected_result
+ ordinary_subroutine => ordinary_dummy
+ protected_subroutine => protected_dummy
+ ordinary_function => protected_result
+ protected_function => ordinary_result
+ ordinary_subroutine => protected_dummy
+ protected_subroutine => ordinary_dummy
+ keep => protected_function()
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'ordinary' that is not PROTECTED_TARGET
+ ordinary => protected_function()
+ ! The interface of ordinary_function has no PROTECTED_TARGET result.
+ ordinary => ordinary_function()
+ ordinary = 1
+ end subroutine
+ subroutine nested_interfaces
+ procedure(ordinary_callback_result), pointer :: ordinary_result_callback
+ procedure(protected_callback_result), pointer :: protected_result_callback
+ procedure(ordinary_callback_dummy), pointer :: ordinary_dummy_callback
+ procedure(protected_callback_dummy), pointer :: protected_dummy_callback
+ procedure(ordinary_nested), pointer :: ordinary_nested_pointer
+ procedure(protected_nested), pointer :: protected_nested_pointer
+ procedure(ordinary_factory), pointer :: ordinary_factory_pointer
+ procedure(protected_factory), pointer :: protected_factory_pointer
+ ordinary_result_callback => protected_callback_result
+ protected_result_callback => ordinary_callback_result
+ protected_dummy_callback => ordinary_callback_dummy
+ ordinary_dummy_callback => protected_callback_dummy
+ protected_nested_pointer => ordinary_nested
+ ordinary_nested_pointer => protected_nested
+ protected_factory_pointer => ordinary_factory
+ ordinary_factory_pointer => protected_factory
+ end subroutine
+end module
diff --git a/flang/test/Semantics/call07.f90 b/flang/test/Semantics/call07.f90
index 7e29fb74dd615..ab27154366d61 100644
--- a/flang/test/Semantics/call07.f90
+++ b/flang/test/Semantics/call07.f90
@@ -49,3 +49,339 @@ subroutine test
call s03(a04)
end subroutine
end module
+
+module protected_target_calls
+ type node
+ integer :: value
+ integer, pointer :: link
+ type(node), pointer :: next
+ end type
+ integer, target :: value
+ interface generic_rank
+ module procedure no_intent_array, elemental_read
+ end interface
+ interface generic_read
+ module procedure read_array, elemental_read
+ end interface
+ interface generic_ordinary_pointer
+ module procedure ordinary_array_pointer
+ end interface
+ interface generic_protected_pointer
+ module procedure readonly_array_pointer
+ end interface
+ interface generic_scalar
+ module procedure no_intent
+ end interface
+contains
+ elemental subroutine elemental_read(x)
+ integer, intent(in) :: x
+ end subroutine
+ subroutine read_scalar(x)
+ integer, intent(in) :: x
+ end subroutine
+ subroutine read_array(x)
+ integer, intent(in) :: x(:)
+ end subroutine
+ subroutine no_intent(x)
+ integer :: x
+ end subroutine
+ subroutine no_intent_array(x)
+ integer :: x(:)
+ end subroutine
+ subroutine write_scalar(x)
+ integer, intent(out) :: x
+ end subroutine
+ subroutine value_scalar(x)
+ integer, value :: x
+ end subroutine
+ subroutine ordinary_pointer(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ subroutine ordinary_array_pointer(x)
+ integer, pointer, intent(in) :: x(:)
+ end subroutine
+ subroutine readonly_pointer(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+ subroutine readonly_array_pointer(x)
+ integer, pointer, protected_target, intent(in) :: x(:)
+ end subroutine
+ subroutine reassociate(x)
+ integer, pointer, protected_target, intent(out) :: x
+ nullify(x)
+ end subroutine
+ subroutine assumed_rank_in(x)
+ integer, intent(in) :: x(..)
+ end subroutine
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => value
+ end function
+ subroutine test(p, a, object, pin)
+ integer, pointer, protected_target :: p, a(:)
+ type(node), pointer, protected_target :: object
+ integer, pointer, protected_target, intent(in) :: pin
+ call read_scalar(p)
+ call read_array(a)
+ call readonly_pointer(p)
+ call readonly_array_pointer(a(1:2))
+ call reassociate(p)
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call no_intent(p)
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call no_intent_array(a(1:2))
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call write_scalar(p)
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call value_scalar(p)
+ !ERROR: PROTECTED_TARGET actual argument requires PROTECTED_TARGET for pointer dummy argument 'x='
+ call ordinary_pointer(p)
+ !ERROR: PROTECTED_TARGET actual argument requires PROTECTED_TARGET for pointer dummy argument 'x='
+ call ordinary_array_pointer(a(1:2))
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'pin' is an INTENT(IN) dummy argument
+ call reassociate(pin)
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call no_intent(object%value)
+ !ERROR: PROTECTED_TARGET actual argument requires PROTECTED_TARGET for pointer dummy argument 'x='
+ call ordinary_pointer(object%link)
+ call readonly_pointer(object%link)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'x=' is not definable
+ !BECAUSE: 'object' is a PROTECTED_TARGET pointer
+ call reassociate(object%link)
+ call write_scalar(object%link)
+ call ordinary_pointer(object%next%link)
+ associate(x => object%value)
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call no_intent(x)
+ end associate
+ associate(x => object%next%value)
+ call no_intent(x)
+ end associate
+ call readonly_pointer(get())
+ call reassociate(object%next%link)
+ !ERROR: PROTECTED_TARGET actual argument requires PROTECTED_TARGET for pointer dummy argument 'x='
+ call ordinary_pointer(get())
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call no_intent(get())
+ associate(x => get())
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call no_intent(x)
+ end associate
+ call no_intent(p + 1)
+ call no_intent((p))
+ call no_intent(get() + 1)
+ call no_intent((get()))
+ call read_scalar((.true. ? p : value))
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call no_intent((.true. ? p : value))
+ !ERROR: PROTECTED_TARGET actual argument requires PROTECTED_TARGET for pointer dummy argument 'x='
+ call ordinary_pointer((.true. ? p : value))
+ call readonly_pointer((.true. ? p : value))
+ print *, associated(p), size(a), shape(a), kind(p)
+ end subroutine
+ subroutine ranks(p)
+ integer, pointer, protected_target, intent(in) :: p(..)
+ select rank(p)
+ rank(0)
+ call read_scalar(p)
+ call readonly_pointer(p)
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call no_intent(p)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ p = 1
+ rank(1)
+ call read_array(p)
+ !ERROR: PROTECTED_TARGET actual argument requires PROTECTED_TARGET for pointer dummy argument 'x='
+ call ordinary_array_pointer(p)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ p(1) = 1
+ rank default
+ call assumed_rank_in(p)
+ end select
+ end subroutine
+ subroutine generic_calls(p, ordinary)
+ integer, pointer, protected_target :: p(:)
+ integer, pointer :: ordinary(:)
+ ! F'2028 C874 is checked after selecting the non-elemental specific.
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call generic_rank(p)
+ call generic_rank(ordinary)
+ call generic_read(p)
+ !ERROR: PROTECTED_TARGET actual argument requires PROTECTED_TARGET for pointer dummy argument 'x='
+ call generic_ordinary_pointer(p)
+ call generic_ordinary_pointer(ordinary)
+ call generic_protected_pointer(p)
+ !ERROR: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'x='
+ call generic_scalar(p(1))
+ call generic_scalar(ordinary(1))
+ end subroutine
+ subroutine null_inquiries(p, array, ordinary)
+ integer, pointer, protected_target :: p, array(:)
+ integer, pointer :: ordinary
+ procedure(read_scalar), pointer :: callback
+ p => null(p)
+ p => null(mold=p)
+ array => null(array)
+ array => null(mold=array)
+ ordinary => null(p)
+ ordinary => null(mold=ordinary)
+ callback => null(callback)
+ callback => null(mold=callback)
+ call readonly_pointer(null(p))
+ call readonly_array_pointer(null(mold=array))
+ call ordinary_pointer(null(mold=p))
+ end subroutine
+end module
+
+module protected_target_protected_actuals
+ integer, target, protected :: x = 1
+contains
+ subroutine read_protected(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end subroutine
+ subroutine read_ordinary(p)
+ integer, pointer, intent(in) :: p
+ end subroutine
+ subroutine owner
+ call read_protected(x)
+ call read_ordinary(x)
+ end subroutine
+end module
+
+subroutine protected_target_protected_actual
+ use protected_target_protected_actuals
+ ! Argument association is not a C864 data-target or initial-data-target.
+ call read_protected(x)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ call read_ordinary(x)
+end subroutine
+
+module protected_target_procedure_arguments
+ integer, target :: value
+contains
+ function ordinary_result() result(r)
+ integer, pointer :: r
+ r => value
+ end function
+ function protected_result() result(r)
+ integer, pointer, protected_target :: r
+ r => value
+ end function
+ subroutine ordinary_dummy(p)
+ integer, pointer, intent(in) :: p
+ end subroutine
+ subroutine protected_dummy(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end subroutine
+ subroutine take_ordinary_result(f)
+ procedure(ordinary_result) :: f
+ end subroutine
+ subroutine take_protected_result(f)
+ procedure(protected_result) :: f
+ end subroutine
+ subroutine take_ordinary_dummy(s)
+ procedure(ordinary_dummy) :: s
+ end subroutine
+ subroutine take_protected_dummy(s)
+ procedure(protected_dummy) :: s
+ end subroutine
+ subroutine take_ordinary_callback(c)
+ procedure(take_ordinary_result) :: c
+ end subroutine
+ subroutine take_protected_callback(c)
+ procedure(take_protected_result) :: c
+ end subroutine
+ subroutine replace_pointer(p)
+ integer, pointer, protected_target, intent(inout) :: p
+ p => protected_result()
+ end subroutine
+ subroutine replace_function(f)
+ procedure(protected_result), pointer, intent(inout) :: f
+ f => protected_result
+ end subroutine
+ subroutine calls
+ ! J3/26-007r1 omits PROTECTED_TARGET from procedure characteristics.
+ call take_protected_result(ordinary_result)
+ call take_ordinary_dummy(protected_dummy)
+ call take_ordinary_result(protected_result)
+ call take_protected_dummy(ordinary_dummy)
+ call take_ordinary_callback(take_protected_result)
+ call take_protected_callback(take_ordinary_result)
+ end subroutine
+ subroutine returned_associations
+ integer, pointer :: p
+ procedure(ordinary_result), pointer :: f
+ ! No constraint applies: the actual arguments are not PROTECTED_TARGET.
+ call replace_pointer(p)
+ p = 1
+ f => ordinary_result
+ call replace_function(f)
+ p => f()
+ p = 1
+ end subroutine
+end module
+
+subroutine protected_target_implicit(p)
+ integer, pointer, protected_target :: p(:)
+ external consume
+ !ERROR: PROTECTED_TARGET actual argument requires an explicit interface
+ call consume(p)
+ !ERROR: PROTECTED_TARGET actual argument requires an explicit interface
+ call consume(p(1))
+ !ERROR: PROTECTED_TARGET actual argument requires an explicit interface
+ call consume(p(1:2))
+end subroutine
+
+subroutine protected_target_known_external(p)
+ integer, pointer, protected_target :: p
+ !ERROR: PROTECTED_TARGET actual argument requires an explicit interface
+ call protected_target_external_in(p)
+end subroutine
+
+subroutine protected_target_external_in(x)
+ integer, intent(in) :: x
+end subroutine
+
+subroutine protected_target_external_interfaces(p, ordinary)
+ integer, pointer, protected_target :: p
+ integer, pointer :: ordinary
+ ! These interfaces differ from the definitions below only in PROTECTED_TARGET,
+ ! which is not a procedure characteristic.
+ interface
+ subroutine ordinary_external_dummy(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+ subroutine protected_external_dummy(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ function protected_external_result() result(r)
+ integer, pointer :: r
+ end function
+ function ordinary_external_result() result(r)
+ integer, pointer, protected_target :: r
+ end function
+ end interface
+ call ordinary_external_dummy(p)
+ call protected_external_dummy(ordinary)
+ ordinary => protected_external_result()
+ p => ordinary_external_result()
+end subroutine
+
+subroutine ordinary_external_dummy(x)
+ integer, pointer, intent(in) :: x
+end subroutine
+subroutine protected_external_dummy(x)
+ integer, pointer, protected_target, intent(in) :: x
+end subroutine
+function ordinary_external_result() result(r)
+ integer, pointer :: r
+ r => null()
+end function
+function protected_external_result() result(r)
+ integer, pointer, protected_target :: r
+ r => null()
+end function
diff --git a/flang/test/Semantics/definable01.f90 b/flang/test/Semantics/definable01.f90
index 5af7e954e4171..9552476bd0e2e 100644
--- a/flang/test/Semantics/definable01.f90
+++ b/flang/test/Semantics/definable01.f90
@@ -1,4 +1,4 @@
-! RUN: not %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s
+! RUN: not %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s --implicit-check-not="No intrinsic or user-defined ASSIGNMENT(=)"
! Test WhyNotDefinable() explanations
module prot
@@ -136,3 +136,135 @@ subroutine inoutlock(lock)
!CHECK: error: Actual argument associated with INTENT(OUT) dummy argument 'lock=' is not definable
call outlock(lock)
end
+
+module protected_target_definition_contexts
+ integer, target :: target
+ type box
+ integer :: value
+ integer, pointer :: link
+ end type
+contains
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => target
+ end function
+ subroutine definitions(p, chars, logical_pointer)
+ integer, pointer, protected_target :: p
+ character(40), pointer, protected_target :: chars
+ logical, pointer, protected_target :: logical_pointer
+ integer, allocatable :: allocated
+ integer :: status
+ character(40) :: input
+ namelist /readonly_namelist/ p
+ !CHECK: error: Left-hand side of assignment is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ if (.false.) p = 1
+ !CHECK: error: Input variable 'p' is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ read(*,*) p
+ !CHECK: error: 'p' may not be used as a DO variable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ do p = 1, 2
+ end do
+ !CHECK: error: NAMELIST input group must not contain undefinable item 'p'
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ read(*, nml=readonly_namelist)
+ !CHECK: error: Internal file variable 'chars' is not definable
+ !CHECK: because: 'chars' is a PROTECTED_TARGET pointer
+ write(chars,*) 1
+ !CHECK: error: NEWUNIT variable 'p' is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ open(file='unused', newunit=p)
+ !CHECK: error: IOSTAT variable 'p' is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ read(1,*,iostat=p)
+ !CHECK: error: IOMSG variable 'chars' is not definable
+ !CHECK: because: 'chars' is a PROTECTED_TARGET pointer
+ read(1,*,iostat=status,iomsg=chars)
+ !CHECK: error: SIZE variable 'p' is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ read(1,'(A)',advance='no',size=p) input
+ !CHECK: error: EXIST variable 'logical_pointer' is not definable
+ !CHECK: because: 'logical_pointer' is a PROTECTED_TARGET pointer
+ inquire(unit=1,exist=logical_pointer)
+ !CHECK: error: Left-hand side of assignment is not definable
+ !CHECK: because: 'chars' is a PROTECTED_TARGET pointer
+ chars(2:4) = 'abc'
+ !CHECK: error: Input variable 'chars' is not definable
+ !CHECK: because: 'chars' is a PROTECTED_TARGET pointer
+ read(*,*) chars(2:4)
+ !CHECK: error: STAT variable 'p' is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ allocate(allocated,stat=p)
+ !CHECK: error: ERRMSG variable 'chars' is not definable
+ !CHECK: because: 'chars' is a PROTECTED_TARGET pointer
+ deallocate(allocated,errmsg=chars)
+ end subroutine
+ subroutine function_results
+ print *, get()
+ !CHECK: error: Left-hand side of assignment is not definable
+ !CHECK: because: 'r' is a PROTECTED_TARGET pointer
+ get() = 1
+ !CHECK: error: Input variable 'get()' is not definable
+ !CHECK: because: 'r' is a PROTECTED_TARGET pointer
+ read(*,*) get()
+ associate(a => get())
+ !CHECK: error: Left-hand side of assignment is not definable
+ !CHECK: because: 'r' is a PROTECTED_TARGET pointer
+ a = 1
+ end associate
+ end subroutine
+ subroutine iolength(p, array, object, input)
+ integer, pointer, protected_target :: p, array(:)
+ type(box), pointer, protected_target :: object
+ integer, intent(in) :: input
+ integer, pointer :: ordinary
+ integer :: length
+ !CHECK: error: IOLENGTH variable 'p' is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ inquire(iolength=p) 1
+ !CHECK: error: IOLENGTH variable 'array' is not definable
+ !CHECK: because: 'array' is a PROTECTED_TARGET pointer
+ inquire(iolength=array(1)) 1
+ !CHECK: error: IOLENGTH variable 'object' is not definable
+ !CHECK: because: 'object' is a PROTECTED_TARGET pointer
+ inquire(iolength=object%value) 1
+ associate(alias => p)
+ !CHECK: error: IOLENGTH variable 'alias' is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ inquire(iolength=alias) 1
+ end associate
+ !CHECK: error: IOLENGTH variable 'get()' is not definable
+ !CHECK: because: 'r' is a PROTECTED_TARGET pointer
+ inquire(iolength=get()) 1
+ inquire(iolength=object%link) p
+ inquire(iolength=length) p
+ inquire(iolength=ordinary) p
+ ! Preserve the existing INTENT(IN) IOLENGTH behavior.
+ inquire(iolength=input) p
+ end subroutine
+end module
+
+module protected_target_defined_assignment
+ type t
+ integer :: value
+ contains
+ procedure :: assign
+ generic :: assignment(=) => assign
+ end type
+contains
+ subroutine assign(lhs, rhs)
+ class(t), intent(out) :: lhs
+ integer, intent(in) :: rhs
+ lhs%value = rhs
+ end subroutine
+ subroutine definitions(p, ordinary)
+ type(t), pointer, protected_target :: p
+ type(t), pointer :: ordinary
+ !CHECK: error: PROTECTED_TARGET actual argument requires INTENT(IN) for nonpointer dummy argument 'lhs='
+ !CHECK: error: Left-hand side of assignment is not definable
+ !CHECK: because: 'p' is a PROTECTED_TARGET pointer
+ p = 1
+ ordinary = 1
+ end subroutine
+end module
diff --git a/flang/test/Semantics/event01b.f90 b/flang/test/Semantics/event01b.f90
index b11118783eaee..5d6c6c32c4e25 100644
--- a/flang/test/Semantics/event01b.f90
+++ b/flang/test/Semantics/event01b.f90
@@ -126,3 +126,13 @@ program test_event_post
event post(concert, errmsg=co_indexed_character[1], stat=co_indexed_integer[1])
end program test_event_post
+
+subroutine protected_target_event_post
+ use iso_fortran_env, only: event_type
+ type(event_type), pointer, protected_target :: readonly
+ type(event_type), pointer :: ordinary
+ !ERROR: EVENT variable is not definable
+ !BECAUSE: 'readonly' is a PROTECTED_TARGET pointer
+ event post(readonly)
+ event post(ordinary)
+end subroutine
diff --git a/flang/test/Semantics/form_team01.f90 b/flang/test/Semantics/form_team01.f90
index 1510a8bb98f74..4b0d76a3f7061 100644
--- a/flang/test/Semantics/form_team01.f90
+++ b/flang/test/Semantics/form_team01.f90
@@ -64,3 +64,13 @@ subroutine test
!ERROR: Must be a scalar value, but is a rank-1 array
FORM TEAM (team_number, team, ERRMSG=array_errvar)
end subroutine
+
+subroutine protected_target_form_team
+ use iso_fortran_env, only: team_type
+ type(team_type), pointer, protected_target :: readonly
+ type(team_type), pointer :: ordinary
+ !ERROR: TEAM variable is not definable
+ !BECAUSE: 'readonly' is a PROTECTED_TARGET pointer
+ form team(1, readonly)
+ form team(1, ordinary)
+end subroutine
diff --git a/flang/test/Semantics/lockstmt01.f90 b/flang/test/Semantics/lockstmt01.f90
index fe2b7e7ba1e00..b7a9bef03d821 100644
--- a/flang/test/Semantics/lockstmt01.f90
+++ b/flang/test/Semantics/lockstmt01.f90
@@ -39,3 +39,14 @@ program test_lock_stmt
lock(lock_var, errmsg=error_message, stat=status, acquired_lock=bool)
end program test_lock_stmt
+
+subroutine protected_target_acquired_lock
+ use iso_fortran_env, only: lock_type
+ type(lock_type), save :: lock_object[*]
+ logical, pointer, protected_target :: readonly
+ logical, pointer :: ordinary
+ !ERROR: ACQUIRED_LOCK variable is not definable
+ !BECAUSE: 'readonly' is a PROTECTED_TARGET pointer
+ lock(lock_object, acquired_lock=readonly)
+ lock(lock_object, acquired_lock=ordinary)
+end subroutine
diff --git a/flang/test/Semantics/modfile29.f90 b/flang/test/Semantics/modfile29.f90
index 7650fe301b289..e1ddec169cfa1 100644
--- a/flang/test/Semantics/modfile29.f90
+++ b/flang/test/Semantics/modfile29.f90
@@ -6,6 +6,8 @@ module m
private :: b
protected :: i
allocatable :: j
+ pointer :: p
+ protected_target :: p
end
!Expect: m.mod
@@ -14,4 +16,5 @@ module m
! real(4),private::b
! integer(4),protected::i
! integer(4),allocatable::j
+! real(4),pointer,protected_target::p
!end
diff --git a/flang/test/Semantics/modfile87.f90 b/flang/test/Semantics/modfile87.f90
index a915b8310df3e..130c1d0f01f91 100644
--- a/flang/test/Semantics/modfile87.f90
+++ b/flang/test/Semantics/modfile87.f90
@@ -1,6 +1,12 @@
! RUN: split-file %s %t
! RUN: %flang_fc1 -fsyntax-only -J%t %t/m.f90
! RUN: %flang_fc1 -fsyntax-only -pedantic -J%t %t/s.f90 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/protected-target.f90
+! RUN: FileCheck --check-prefix=MOD-PT %s < %t/protected_target_mod.mod
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/protected-target-use.f90
+! RUN: %python %S/test_errors.py %t/protected-target-errors.f90 %flang_fc1 -J%t
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/protected-target-interfaces.f90
+! RUN: %python %S/test_errors.py %t/protected-target-separate.f90 %flang_fc1 -J%t
! When a module and its submodule are compiled in separate
! invocations (so that the submodule's parent module scope is read back from
@@ -23,3 +29,155 @@ subroutine inside_one()
end submodule
!CHECK: portability: Subprogram 'inside_one' in this submodule is missing the MODULE prefix
+
+!--- protected-target.f90
+module protected_target_mod
+ integer, target :: value
+ integer, target, protected :: protected_value
+ integer, pointer, protected_target :: p
+ type t
+ integer, pointer, protected_target :: component
+ end type
+contains
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => value
+ end function
+ subroutine consume(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+end module
+
+! MOD-PT-DAG: integer(4),pointer,protected_target::p
+! MOD-PT-DAG: integer(4),pointer,protected_target::component
+! MOD-PT-DAG: integer(4),pointer,protected_target::r
+! MOD-PT-DAG: integer(4),intent(in),pointer,protected_target::x
+
+!--- protected-target-use.f90
+subroutine use_protected_target
+ use protected_target_mod, only: p, get, consume, t, protected_value
+ integer, pointer, protected_target :: keep
+ type(t) :: object
+ procedure(get), pointer :: get_pointer
+ procedure(consume), pointer :: consume_pointer
+ keep => p
+ object = t(p)
+ keep => get()
+ get_pointer => get
+ consume_pointer => consume
+ call consume(p)
+ call consume(object%component)
+ call consume(protected_value)
+ print *, p
+ nullify(keep)
+end subroutine
+
+!--- protected-target-errors.f90
+subroutine imported_protected_target
+ use protected_target_mod, only: imported => p, get, consume, t
+ integer, pointer :: ordinary
+ type(t) :: object
+ abstract interface
+ function ordinary_result() result(r)
+ integer, pointer :: r
+ end function
+ subroutine ordinary_dummy(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ end interface
+ procedure(ordinary_result), pointer :: result_pointer
+ procedure(ordinary_dummy), pointer :: dummy_pointer
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'ordinary' that is not PROTECTED_TARGET
+ ordinary => imported
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'ordinary' that is not PROTECTED_TARGET
+ ordinary => get()
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ imported = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: 'component' is a PROTECTED_TARGET pointer
+ object%component = 1
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer
+ deallocate(imported)
+ ! PROTECTED_TARGET is not a procedure characteristic.
+ result_pointer => get
+ dummy_pointer => consume
+end subroutine
+
+!--- protected-target-interfaces.f90
+module protected_target_interfaces
+ abstract interface
+ function ordinary_result() result(r)
+ integer, pointer :: r
+ end function
+ function protected_result() result(r)
+ integer, pointer, protected_target :: r
+ end function
+ subroutine ordinary_dummy(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ subroutine protected_dummy(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+ end interface
+ interface
+ module subroutine ordinary_dummy_body(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ module subroutine protected_dummy_body(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+ module function ordinary_result_body() result(r)
+ integer, pointer :: r
+ end function
+ module function protected_result_body() result(r)
+ integer, pointer, protected_target :: r
+ end function
+ module subroutine ordinary_nested_body(f)
+ procedure(ordinary_result) :: f
+ end subroutine
+ module subroutine protected_nested_body(f)
+ procedure(protected_result) :: f
+ end subroutine
+ module subroutine ordinary_nested_dummy_body(s)
+ procedure(ordinary_dummy) :: s
+ end subroutine
+ module subroutine protected_nested_dummy_body(s)
+ procedure(protected_dummy) :: s
+ end subroutine
+ end interface
+end module
+
+!--- protected-target-separate.f90
+! PROTECTED_TARGET is not a procedure characteristic, so these definitions
+! match the interface bodies read from the module file.
+submodule(protected_target_interfaces) protected_target_separate
+contains
+ module subroutine ordinary_dummy_body(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+ module subroutine protected_dummy_body(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ module function ordinary_result_body() result(r)
+ integer, pointer, protected_target :: r
+ r => null()
+ end function
+ module function protected_result_body() result(r)
+ integer, pointer :: r
+ r => null()
+ end function
+ module subroutine ordinary_nested_body(f)
+ procedure(protected_result) :: f
+ end subroutine
+ module subroutine protected_nested_body(f)
+ procedure(ordinary_result) :: f
+ end subroutine
+ module subroutine ordinary_nested_dummy_body(s)
+ procedure(protected_dummy) :: s
+ end subroutine
+ module subroutine protected_nested_dummy_body(s)
+ procedure(ordinary_dummy) :: s
+ end subroutine
+end submodule
diff --git a/flang/test/Semantics/resolve42.f90 b/flang/test/Semantics/resolve42.f90
index 13caff0b87d85..f61c41027ec54 100644
--- a/flang/test/Semantics/resolve42.f90
+++ b/flang/test/Semantics/resolve42.f90
@@ -130,3 +130,32 @@ subroutine sub
!ERROR: COMMON block /c4/ may not have the member 'x2' whose derived type 't2' has a component '%a%pp' that is ALLOCATABLE or has default initialization
common /c4/ x2
end
+
+subroutine protected_target_common
+ integer, pointer, protected_target :: p
+ !ERROR: PROTECTED_TARGET pointer 'p' may not appear in COMMON block /readonly_pointer/
+ common /readonly_pointer/ p
+end subroutine
+
+subroutine protected_target_component_common
+ type inner
+ sequence
+ integer, pointer, protected_target :: p
+ end type
+ type outer
+ sequence
+ type(inner) :: component
+ end type
+ type(outer) :: object
+ !ERROR: COMMON block /readonly_component/ member 'object' has PROTECTED_TARGET component 'p'
+ common /readonly_component/ object
+end subroutine
+
+subroutine ordinary_pointer_common
+ type inner
+ sequence
+ integer, pointer, protected_target :: p
+ end type
+ type(inner), pointer :: ordinary
+ common /ordinary_pointer/ ordinary
+end subroutine
diff --git a/flang/test/Semantics/resolve81.f90 b/flang/test/Semantics/resolve81.f90
index 23651cbb257e7..140917bcf35e1 100644
--- a/flang/test/Semantics/resolve81.f90
+++ b/flang/test/Semantics/resolve81.f90
@@ -64,3 +64,49 @@ subroutine testTypeDecl(arg1, arg2, arg3, arg4, arg5, arg6)
arg2 =3.5
end subroutine testTypeDecl
end module m
+
+module protected_target_declarations
+ implicit none
+ integer, target :: x
+ integer, pointer, protected_target :: p
+ type good
+ integer, protected_target, pointer :: component
+ end type
+ type bad
+ !ERROR: An entity with PROTECTED_TARGET must be a data pointer
+ integer, protected_target :: component
+ end type
+ !ERROR: An entity with PROTECTED_TARGET must be a data pointer
+ integer, protected_target :: nonpointer
+ !WARNING: Attribute 'PROTECTED_TARGET' cannot be used more than once [-Wredundant-attribute]
+ integer, pointer, protected_target, protected_target :: duplicate
+ integer, pointer :: statement1, statement2
+ protected_target statement1
+ !ERROR: PROTECTED_TARGET attribute was already specified on 'statement1'
+ protected_target :: statement1
+ !ERROR: PROTECTED_TARGET attribute was already specified on 'statement2'
+ protected_target :: statement2, statement2
+ protected_target :: missing_pointer
+ !ERROR: An entity with PROTECTED_TARGET must be a data pointer
+ integer :: missing_pointer
+ !ERROR: An entity with PROTECTED_TARGET must be a data pointer
+ procedure(callback_interface), pointer :: callback
+ protected_target callback
+contains
+ subroutine callback_interface
+ end subroutine
+ function result_name() result(r)
+ integer, pointer, protected_target :: r
+ r => x
+ end function
+ function function_name()
+ integer, pointer, protected_target :: function_name
+ function_name => x
+ end function
+ subroutine statement_first
+ protected_target :: q
+ integer, pointer :: q
+ q => x
+ nullify(q)
+ end subroutine
+end module
diff --git a/flang/test/Semantics/resolve94.f90 b/flang/test/Semantics/resolve94.f90
index 616d91fbaa94b..a56bbe0def1b5 100644
--- a/flang/test/Semantics/resolve94.f90
+++ b/flang/test/Semantics/resolve94.f90
@@ -91,3 +91,40 @@ subroutine s()
!ERROR: STAT= specifier must be a scalar integer variable
r = c[1,2,3, STAT=MASK(2), STAT=MASK(3)]
end subroutine s
+
+subroutine protected_target_image_selector
+ use iso_fortran_env, only: notify_type
+ type t
+ integer :: stat
+ integer, pointer :: link
+ end type
+ type holder
+ integer, pointer, protected_target :: stat
+ type(notify_type), pointer, protected_target :: readonly
+ type(notify_type), pointer :: ordinary
+ end type
+ real, save :: c[*]
+ real :: r
+ integer, pointer, protected_target :: ps, stats(:)
+ type(t), pointer, protected_target :: object
+ type(holder) :: h
+ integer, pointer :: ordinary
+ !ERROR: Image selector STAT variable is not definable
+ !BECAUSE: 'ps' is a PROTECTED_TARGET pointer
+ r = c[1, stat=ps]
+ !ERROR: Image selector STAT variable is not definable
+ !BECAUSE: 'stats' is a PROTECTED_TARGET pointer
+ r = c[1, stat=stats(1)]
+ !ERROR: Image selector STAT variable is not definable
+ !BECAUSE: 'object' is a PROTECTED_TARGET pointer
+ c[1, stat=object%stat] = r
+ !ERROR: Image selector STAT variable is not definable
+ !BECAUSE: 'stat' is a PROTECTED_TARGET pointer
+ r = c[1, stat=h%stat]
+ r = c[1, stat=ordinary]
+ r = c[1, stat=object%link]
+ !ERROR: Image selector NOTIFY variable is not definable
+ !BECAUSE: 'readonly' is a PROTECTED_TARGET pointer
+ c[1, notify=h%readonly] = r
+ c[1, notify=h%ordinary] = r
+end subroutine
diff --git a/flang/test/Semantics/structconst09.f90 b/flang/test/Semantics/structconst09.f90
index c129f11606857..ccb6a1b83de24 100644
--- a/flang/test/Semantics/structconst09.f90
+++ b/flang/test/Semantics/structconst09.f90
@@ -35,3 +35,51 @@ real function internal()
end
end
end
+
+module protected_target_constructors
+ type ordinary
+ integer, pointer :: p(:)
+ end type
+ type readonly
+ integer, pointer, protected_target :: p(:)
+ end type
+ type data
+ integer :: value
+ end type
+ type node
+ integer :: array(3)
+ integer, pointer :: link(:)
+ end type
+ integer, target :: values(3)
+contains
+ function get() result(r)
+ integer, pointer, protected_target :: r(:)
+ r => values
+ end function
+ subroutine constructors(p, n)
+ integer, pointer, protected_target :: p(:)
+ type(node), pointer, protected_target :: n
+ type(ordinary) :: writable
+ type(readonly) :: protected
+ type(data) :: copied
+ protected = readonly(p)
+ protected = readonly(p(1:2))
+ protected = readonly(n%array)
+ protected = readonly(get())
+ protected = readonly(null())
+ writable = ordinary(n%link)
+ copied = data(p(1))
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'p' that is not PROTECTED_TARGET
+ writable = ordinary(p)
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'p' that is not PROTECTED_TARGET
+ writable = ordinary(p(1:2))
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'p' that is not PROTECTED_TARGET
+ writable = ordinary(n%array)
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'p' that is not PROTECTED_TARGET
+ writable = ordinary(get())
+ associate(a => n%array)
+ !ERROR: A PROTECTED_TARGET target may not be associated with pointer 'p' that is not PROTECTED_TARGET
+ writable = ordinary(a)
+ end associate
+ end subroutine
+end module
More information about the flang-commits
mailing list