[flang-commits] [flang] [flang] Implement the PROTECTED_TARGET attribute from the F2028 draft (PR #230957)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Sun Oct 11 06:07:58 PDT 2026
https://github.com/Saieiei created https://github.com/llvm/llvm-project/pull/230957
Flang fails to parse the PROTECTED_TARGET attribute and statement from the Fortran 2028 working draft (J3/26-007r1, 8.5.16 and 8.6.14).
Add the attribute to the parser, semantics, module files and procedure characteristics, and report violations of C781, C866-C874 and C8109 as errors. Defining the target, or a subobject of it, through such a pointer is rejected. Pointer assignment, NULLIFY and ALLOCATE with SOURCE= of the pointer itself are accepted unless another attribute, such as INTENT(IN), forbids them. The data-object MOLD dummy of NULL now has INTENT(IN), the default for intrinsic dummies, so NULL(p%a) satisfies C874.
The draft's C864 conflicts with 8.5.16 NOTE 1. For a PROTECTED_TARGET pointer, Flang follows NOTE 1: association with a use-associated PROTECTED target is accepted, without the optional -Wpointer-to-undefinable warning. The draft does not list PROTECTED_TARGET among the characteristics of dummy arguments or function results (15.3.2.2, 15.3.3). It is treated as one here, so a procedure pointer or interface cannot drop it from a pointer dummy. The optional diagnostic suggested in NOTE 2 is not implemented.
Assisted-by: GitHub Copilot
>From 54fecdff32eb80e6778a3e6ccd4e61bd546d0943 Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Sun, 11 Oct 2026 08:07:47 -0500
Subject: [PATCH] [flang] Implement the PROTECTED_TARGET attribute from the
F2028 draft
Flang fails to parse the PROTECTED_TARGET attribute and statement from the Fortran 2028 working draft (J3/26-007r1, 8.5.16 and 8.6.14).
Add the attribute to the parser, semantics, module files and procedure characteristics, and report violations of C781, C866-C874 and C8109 as errors. Defining the target, or a subobject of it, through such a pointer is rejected. Pointer assignment, NULLIFY and ALLOCATE with SOURCE= of the pointer itself are accepted unless another attribute, such as INTENT(IN), forbids them. The data-object MOLD dummy of NULL now has INTENT(IN), the default for intrinsic dummies, so NULL(p%a) satisfies C874.
The draft's C864 conflicts with 8.5.16 NOTE 1. For a PROTECTED_TARGET pointer, Flang follows NOTE 1: association with a use-associated PROTECTED target is accepted, without the optional -Wpointer-to-undefinable warning. The draft does not list PROTECTED_TARGET among the characteristics of dummy arguments or function results (15.3.2.2, 15.3.3). It is treated as one here, so a procedure pointer or interface cannot drop it from a pointer dummy. The optional diagnostic suggested in NOTE 2 is not implemented.
Assisted-by: GitHub Copilot
---
flang/docs/FortranStandardsSupport.md | 14 ++
.../include/flang/Evaluate/characteristics.h | 5 +-
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 27 +++-
flang/include/flang/Semantics/attr.h | 4 +-
flang/include/flang/Semantics/tools.h | 9 ++
flang/lib/Evaluate/characteristics.cpp | 3 +
flang/lib/Evaluate/intrinsics.cpp | 1 +
flang/lib/Parser/Fortran-parsers.cpp | 13 +-
flang/lib/Parser/misc-parsers.h | 2 +
flang/lib/Parser/program-parsers.cpp | 1 +
flang/lib/Parser/unparse.cpp | 4 +
flang/lib/Semantics/check-allocate.cpp | 5 +
flang/lib/Semantics/check-call.cpp | 19 +++
flang/lib/Semantics/check-declarations.cpp | 21 +++
flang/lib/Semantics/definable.cpp | 29 ++++
flang/lib/Semantics/pointer-assignment.cpp | 36 ++++-
flang/lib/Semantics/resolve-names.cpp | 8 +-
flang/lib/Semantics/tools.cpp | 38 +++++
flang/test/Parser/protected-target.f90 | 24 +++
flang/test/Semantics/Inputs/modfile89-a.f90 | 20 +++
flang/test/Semantics/modfile89.f90 | 36 +++++
flang/test/Semantics/protected-target01.f90 | 103 ++++++++++++
flang/test/Semantics/protected-target02.f90 | 146 ++++++++++++++++++
flang/test/Semantics/protected-target03.f90 | 96 ++++++++++++
flang/test/Semantics/protected-target04.f90 | 111 +++++++++++++
flang/test/Semantics/protected-target05.f90 | 45 ++++++
flang/test/Semantics/protected-target06.f90 | 40 +++++
28 files changed, 840 insertions(+), 22 deletions(-)
create mode 100644 flang/test/Parser/protected-target.f90
create mode 100644 flang/test/Semantics/Inputs/modfile89-a.f90
create mode 100644 flang/test/Semantics/modfile89.f90
create mode 100644 flang/test/Semantics/protected-target01.f90
create mode 100644 flang/test/Semantics/protected-target02.f90
create mode 100644 flang/test/Semantics/protected-target03.f90
create mode 100644 flang/test/Semantics/protected-target04.f90
create mode 100644 flang/test/Semantics/protected-target05.f90
create mode 100644 flang/test/Semantics/protected-target06.f90
diff --git a/flang/docs/FortranStandardsSupport.md b/flang/docs/FortranStandardsSupport.md
index dd8bda23cb495..80ab6e044412f 100644
--- a/flang/docs/FortranStandardsSupport.md
+++ b/flang/docs/FortranStandardsSupport.md
@@ -23,6 +23,20 @@ There is no distinction made between support in the Parser/Semantics and the MLI
Note: The two major missing features in Flang at present are coarrays and parameterized derived types (PDTs) with length type parameters.
+## Fortran 2028 working draft
+
+Flang supports the `PROTECTED_TARGET` data-pointer attribute and statement
+from J3/26-007r1 (8.5.16 and 8.6.14), including pointer components. The target
+cannot be defined through such a pointer; pointer reassociation and `NULLIFY`
+remain permitted unless another attribute restricts them. Allocation requires
+`SOURCE=`, and deallocation through the pointer is prohibited.
+
+The draft's C864 conflicts with the example in 8.5.16 NOTE 1. Flang follows
+the example for `PROTECTED_TARGET` pointers: association with a use-associated
+nonpointer `PROTECTED` target is accepted without the optional
+undefinable-target warning. Ordinary-pointer behavior is unchanged.
+The optional allocation-lifetime warning described in NOTE 2 is not implemented.
+
## Fortran 2023
See [document](F202X.md) for a brief discussion about the new features in Fortran 2023. The following table summarizes the
status of all important Fortran 2023 features. The table entries are based on the document [The new features in Fortran 2023](https://wg5-fortran.org/N2201-N2250/N2212.pdf).
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 1ba0bf693c763..bce75ce9ce360 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -234,7 +234,8 @@ class TypeAndShape {
// 15.3.2.2
struct DummyDataObject {
ENUM_CLASS(Attr, Optional, Allocatable, Asynchronous, Contiguous, Value,
- Volatile, Pointer, Target, DeducedFromActual, OnlyIntrinsicInquiry)
+ Volatile, Pointer, ProtectedTarget, Target, DeducedFromActual,
+ OnlyIntrinsicInquiry)
using Attrs = common::EnumSet<Attr, Attr_enumSize>;
static bool IdenticalSignificantAttrs(const Attrs &x, const Attrs &y) {
return (x - Attr::DeducedFromActual) == (y - Attr::DeducedFromActual);
@@ -327,7 +328,7 @@ using DummyArguments = std::vector<DummyArgument>;
// 15.3.3
struct FunctionResult {
- ENUM_CLASS(Attr, Allocatable, Pointer, Contiguous)
+ 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..3c00589b5e284 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -173,6 +173,7 @@ struct ParameterStmt; // R851
struct OldParameterStmt;
struct PointerStmt; // R853
struct ProtectedStmt; // R855
+struct ProtectedTargetStmt; // F2028 R863
struct SaveStmt; // R856
struct TargetStmt; // R859
struct ValueStmt; // R861
@@ -372,7 +373,8 @@ EMPTY_CLASS(ErrorRecovery);
// access-stmt | allocatable-stmt | asynchronous-stmt | bind-stmt |
// codimension-stmt | contiguous-stmt | dimension-stmt | external-stmt |
// intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
-// pointer-stmt | protected-stmt | save-stmt | target-stmt |
+// pointer-stmt | protected-stmt | protected-target-stmt | save-stmt |
+// target-stmt |
// volatile-stmt | value-stmt | common-stmt | equivalence-stmt
// Extension: (Cray) based POINTER statement
// Extension: CUDA data attribute statement
@@ -386,9 +388,10 @@ struct OtherSpecificationStmt {
common::Indirection<IntentStmt>, common::Indirection<IntrinsicStmt>,
common::Indirection<NamelistStmt>, common::Indirection<OptionalStmt>,
common::Indirection<PointerStmt>, common::Indirection<ProtectedStmt>,
- common::Indirection<SaveStmt>, common::Indirection<TargetStmt>,
- common::Indirection<ValueStmt>, common::Indirection<VolatileStmt>,
- common::Indirection<CommonStmt>, common::Indirection<EquivalenceStmt>,
+ common::Indirection<ProtectedTargetStmt>, common::Indirection<SaveStmt>,
+ common::Indirection<TargetStmt>, common::Indirection<ValueStmt>,
+ common::Indirection<VolatileStmt>, common::Indirection<CommonStmt>,
+ common::Indirection<EquivalenceStmt>,
common::Indirection<BasedPointerStmt>,
common::Indirection<CUDAAttributesStmt>>
u;
@@ -995,9 +998,11 @@ struct ComponentArraySpec {
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// PROTECTED_TARGET |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE | UNIFIED
EMPTY_CLASS(Allocatable);
EMPTY_CLASS(Pointer);
+EMPTY_CLASS(ProtectedTarget);
EMPTY_CLASS(Contiguous);
// CUDA-data-attr [( IMPLICIT )]
// The (IMPLICIT) qualifier marks an attribute that the compiler applied on the
@@ -1013,7 +1018,8 @@ struct CUDADataAttrSpec {
struct ComponentAttrSpec {
UNION_CLASS_BOILERPLATE(ComponentAttrSpec);
std::variant<AccessSpec, Allocatable, CoarraySpec, Contiguous,
- ComponentArraySpec, Pointer, CUDADataAttrSpec, ErrorRecovery>
+ ComponentArraySpec, Pointer, ProtectedTarget, CUDADataAttrSpec,
+ ErrorRecovery>
u;
};
@@ -1405,7 +1411,8 @@ WRAPPER_CLASS(RankClause, ScalarIntConstantExpr);
// CODIMENSION lbracket coarray-spec rbracket | CONTIGUOUS |
// DIMENSION ( array-spec ) | EXTERNAL | INTENT ( intent-spec ) |
// INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
-// PROTECTED | RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
+// PROTECTED | PROTECTED_TARGET | RANK ( scalar-int-constant-expr ) |
+// SAVE | TARGET |
// VALUE | VOLATILE |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE
EMPTY_CLASS(Asynchronous);
@@ -1422,8 +1429,8 @@ struct AttrSpec {
UNION_CLASS_BOILERPLATE(AttrSpec);
std::variant<AccessSpec, Allocatable, Asynchronous, CoarraySpec, Contiguous,
ArraySpec, External, IntentSpec, Intrinsic, LanguageBindingSpec, Optional,
- Parameter, Pointer, Protected, RankClause, Save, Target, Value, Volatile,
- CUDADataAttrSpec>
+ Parameter, Pointer, Protected, ProtectedTarget, RankClause, Save, Target,
+ Value, Volatile, CUDADataAttrSpec>
u;
};
@@ -1616,6 +1623,10 @@ WRAPPER_CLASS(PointerStmt, std::list<PointerDecl>);
// R855 protected-stmt -> PROTECTED [::] entity-name-list
WRAPPER_CLASS(ProtectedStmt, std::list<Name>);
+// F2028 R863 protected-target-stmt ->
+// PROTECTED_TARGET [::] variable-name-list
+WRAPPER_CLASS(ProtectedTargetStmt, std::list<Name>);
+
// R857 saved-entity -> object-name | proc-pointer-name | / common-block-name /
// R858 proc-pointer-name -> name
struct SavedEntity {
diff --git a/flang/include/flang/Semantics/attr.h b/flang/include/flang/Semantics/attr.h
index d8b323e88f650..8a76ac6d50bab 100644
--- a/flang/include/flang/Semantics/attr.h
+++ b/flang/include/flang/Semantics/attr.h
@@ -23,8 +23,8 @@ namespace Fortran::semantics {
ENUM_CLASS(Attr, ABSTRACT, ALLOCATABLE, ASYNCHRONOUS, BIND_C, CONTIGUOUS,
DEFERRED, ELEMENTAL, EXTENDS, EXTERNAL, IMPURE, INTENT_IN, INTENT_INOUT,
INTENT_OUT, INTRINSIC, MODULE, NON_OVERRIDABLE, NON_RECURSIVE, NOPASS,
- OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PUBLIC, PURE,
- RECURSIVE, SAVE, SIMPLE, TARGET, VALUE, VOLATILE)
+ OPTIONAL, PARAMETER, PASS, POINTER, PRIVATE, PROTECTED, PROTECTED_TARGET,
+ PUBLIC, PURE, RECURSIVE, SAVE, SIMPLE, TARGET, VALUE, VOLATILE)
// Set of attributes
class Attrs : public common::EnumSet<Attr, Attr_enumSize> {
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index d91a7d11a38c9..460e678ebe532 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -178,6 +178,15 @@ inline bool IsIntentOut(const Symbol &symbol) {
inline bool IsProtected(const Symbol &symbol) {
return symbol.attrs().test(Attr::PROTECTED);
}
+inline bool IsProtectedTarget(const Symbol &symbol) {
+ return symbol.GetUltimate().attrs().test(Attr::PROTECTED_TARGET);
+}
+// The PROTECTED_TARGET pointer whose target (or a subobject of it) is
+// designated, if any. Does not follow a component pointer's separate target.
+// For a pointer definition, check the containing object, not the final pointer.
+const Symbol *FindProtectedTarget(
+ const evaluate::DataRef &, bool isPointerDefinition = false);
+const Symbol *FindProtectedTarget(const evaluate::Expr<evaluate::SomeType> &);
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..b8da9feb11c29 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -439,6 +439,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());
@@ -1075,6 +1076,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;
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index dda75d56fa615..d4c2e7afeff9c 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -3199,6 +3199,7 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
*type, GetShape(context, *mold)};
args.emplace_back(
"mold"s, characteristics::DummyDataObject{typeAndShape});
+ args.back().SetIntent(common::Intent::In);
fResult.emplace(std::move(typeAndShape));
isAllocatableMold = IsAllocatableDesignator(*mold);
} else {
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 263ce9249a8b2..94159cb3e1c78 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -469,6 +469,7 @@ TYPE_PARSER(construct<DataComponentDefStmt>(declarationTypeSpec,
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// PROTECTED_TARGET |
// CUDA-data-attr
TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(allocatable) ||
@@ -476,6 +477,7 @@ TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(contiguous) ||
construct<ComponentAttrSpec>("DIMENSION" >> componentArraySpec) ||
construct<ComponentAttrSpec>(pointer) ||
+ construct<ComponentAttrSpec>(protectedTarget) ||
extension<LanguageFeature::CUDA>(
construct<ComponentAttrSpec>(Parser<CUDADataAttrSpec>{})) ||
construct<ComponentAttrSpec>(recovery(
@@ -742,7 +744,8 @@ TYPE_PARSER(
// CODIMENSION lbracket coarray-spec rbracket | CONTIGUOUS |
// DIMENSION ( array-spec ) | EXTERNAL | INTENT ( intent-spec ) |
// INTRINSIC | language-binding-spec | OPTIONAL | PARAMETER | POINTER |
-// PROTECTED | RANK ( scalar-int-constant-expr ) | SAVE | TARGET |
+// PROTECTED | PROTECTED_TARGET | RANK ( scalar-int-constant-expr ) |
+// SAVE | TARGET |
// VALUE | VOLATILE |
// CUDA-data-attr
TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
@@ -756,7 +759,8 @@ TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
construct<AttrSpec>(construct<Intrinsic>("INTRINSIC"_tok)) ||
construct<AttrSpec>(languageBindingSpec) || construct<AttrSpec>(optional) ||
construct<AttrSpec>(construct<Parameter>("PARAMETER"_tok)) ||
- construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedAttr) ||
+ construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedTarget) ||
+ construct<AttrSpec>(protectedAttr) ||
construct<AttrSpec>("RANK" >>
construct<RankClause>(parenthesized(scalarIntConstantExpr))) ||
construct<AttrSpec>(save) ||
@@ -1050,6 +1054,11 @@ TYPE_PARSER(
TYPE_PARSER(
construct<ProtectedStmt>("PROTECTED" >> maybe("::"_tok) >> listOfNames))
+// F2028 R863 protected-target-stmt ->
+// PROTECTED_TARGET [::] variable-name-list
+TYPE_PARSER(construct<ProtectedTargetStmt>(
+ "PROTECTED_TARGET" >> maybe("::"_tok) >> listOfNames))
+
// R856 save-stmt -> SAVE [[::] saved-entity-list]
TYPE_PARSER(construct<SaveStmt>(
"SAVE" >> defaulted(maybe("::"_tok) >>
diff --git a/flang/lib/Parser/misc-parsers.h b/flang/lib/Parser/misc-parsers.h
index 4a318e05bb4b8..355ca918b32e3 100644
--- a/flang/lib/Parser/misc-parsers.h
+++ b/flang/lib/Parser/misc-parsers.h
@@ -50,6 +50,8 @@ constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
+constexpr auto protectedTarget{
+ construct<ProtectedTarget>("PROTECTED_TARGET"_tok)};
constexpr auto save{construct<Save>("SAVE"_tok)};
template <typename A> common::IfNoLvalue<std::list<A>, A> singletonList(A &&x) {
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 08283a8be35e3..933214037ed2d 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -232,6 +232,7 @@ TYPE_PARSER(first(
construct<OtherSpecificationStmt>(indirect(Parser<NamelistStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<OptionalStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<PointerStmt>{})),
+ construct<OtherSpecificationStmt>(indirect(Parser<ProtectedTargetStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<ProtectedStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<SaveStmt>{})),
construct<OtherSpecificationStmt>(indirect(Parser<TargetStmt>{})),
diff --git a/flang/lib/Parser/unparse.cpp b/flang/lib/Parser/unparse.cpp
index a046c08e710c6..20513f6d376e4 100644
--- a/flang/lib/Parser/unparse.cpp
+++ b/flang/lib/Parser/unparse.cpp
@@ -634,6 +634,7 @@ class UnparseVisitor {
void Post(const Optional &) { Word("OPTIONAL"); }
void Post(const Parameter &) { Word("PARAMETER"); }
void Post(const Protected &) { Word("PROTECTED"); }
+ void Post(const ProtectedTarget &) { Word("PROTECTED_TARGET"); }
void Post(const Save &) { Word("SAVE"); }
void Post(const Target &) { Word("TARGET"); }
void Post(const Value &) { Word("VALUE"); }
@@ -719,6 +720,9 @@ class UnparseVisitor {
void Unparse(const ProtectedStmt &x) { // R855
Word("PROTECTED :: "), Walk(x.v, ", ");
}
+ void Unparse(const ProtectedTargetStmt &x) { // F2028 R863
+ Word("PROTECTED_TARGET :: "), Walk(x.v, ", ");
+ }
void Unparse(const SaveStmt &x) { // R856
Word("SAVE"), Walk(" :: ", x.v, ", ");
}
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index e797b978c4bd3..134b420ee2392 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -492,6 +492,11 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
CHECK(context.AnyFatalError());
return false;
}
+ if (IsProtectedTarget(*ultimate_) && !allocateInfo_.gotSource) { // F2028 C869
+ context.Say(name_.source,
+ "An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE="_err_en_US);
+ return false;
+ }
if (!IsVariableName(*ultimate_)) { // C932 pre-requisite
context.Say(name_.source,
"Name in ALLOCATE statement must be a variable name"_err_en_US);
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index feabf0cd33bf0..4939bd667a34d 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -67,6 +67,10 @@ 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 (FindProtectedTarget(*expr)) { // F2028 C873
+ messages.Say(
+ "A PROTECTED_TARGET pointer or a subobject of its target requires an explicit interface"_err_en_US);
+ }
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
@@ -399,6 +403,21 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
bool dummyIsPointer{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
+ if (FindProtectedTarget(actual)) {
+ if (dummyIsPointer &&
+ !dummy.attrs.test(
+ characteristics::DummyDataObject::Attr::ProtectedTarget)) {
+ messages.Say( // F2028 C872
+ "A PROTECTED_TARGET pointer or a subobject of its target may not be associated with %s without PROTECTED_TARGET"_err_en_US,
+ dummyName);
+ return;
+ } else if (!dummyIsPointer && dummy.intent != common::Intent::In) {
+ messages.Say( // F2028 C874
+ "A PROTECTED_TARGET pointer or a subobject of its target may be associated only with a nonpointer %s that has INTENT(IN)"_err_en_US,
+ dummyName);
+ return;
+ }
+ }
bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer};
allowActualArgumentConversions &= !dummyIsAllocatableOrPointer;
bool typesCompatibleWithIgnoreTKR{
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 2abefd381850a..83c1e63e87b53 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -347,6 +347,17 @@ void CheckHelper::Check(const Symbol &symbol) {
"A PROTECTED entity may not be in a common block"_err_en_US);
}
}
+ if (symbol.attrs().test(Attr::PROTECTED_TARGET)) {
+ // F2028 C781, C8109; 8.5.16 applies only to data pointers.
+ if (!IsObjectPointer(&symbol)) {
+ messages_.Say(
+ "An entity with the PROTECTED_TARGET attribute must be a data pointer"_err_en_US);
+ }
+ if (FindCommonBlockContaining(symbol)) { // F2028 C867
+ messages_.Say(
+ "A PROTECTED_TARGET pointer may not be in a common block"_err_en_US);
+ }
+ }
if (IsPointer(symbol)) {
CheckPointer(symbol);
}
@@ -620,6 +631,16 @@ void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
derived->typeSymbol()),
*ref);
}
+ if (!IsPointer(*ref)) {
+ if (const Symbol *component{FindUltimateComponent(
+ *derived, IsProtectedTarget)}) { // F2028 C867
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Object '%s' in COMMON block /%s/ has PROTECTED_TARGET pointer component '%s'"_err_en_US,
+ ref->name(), symbol.name(), component->name()),
+ *component);
+ }
+ }
}
}
}
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index d6a654683001f..bcd01e9851519 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -212,6 +212,12 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
} else if (!IsPointer(ultimate)) {
return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
}
+ if (IsProtectedTarget(ultimate) &&
+ flags.test(DefinabilityFlag::PotentialDeallocation)) {
+ return BlameSymbol(at,
+ "'%s' is a PROTECTED_TARGET pointer and may not be deallocated"_en_US,
+ original);
+ }
return std::nullopt; // pointer assignment - skip following checks
}
if (!flags.test(DefinabilityFlag::AllowEventLockOrNotifyType) &&
@@ -253,6 +259,14 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags,
const evaluate::DataRef &dataRef) {
+ // F2028 C866 and 8.5.16 p2. Defining the final pointer's association is
+ // permitted, but defining a descriptor in its protected target is not.
+ if (const Symbol *protectedPointer{FindProtectedTarget(
+ dataRef, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable via that pointer"_en_US,
+ *protectedPointer);
+ }
auto whyNotBase{
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
@@ -270,6 +284,12 @@ static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags, const Symbol &original) {
+ if (const Symbol *pointer{FindProtectedTarget(evaluate::DataRef{original},
+ flags.test(DefinabilityFlag::PointerDefinition))}) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable via that pointer"_en_US,
+ *pointer);
+ }
auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
/*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
if (!whyNotBase || !whyNotBase->IsFatal()) {
@@ -411,6 +431,11 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
*procSym, expr.AsFortran());
}
if (const auto *component{procDesignator->GetComponent()}) {
+ if (const Symbol *pointer{FindProtectedTarget(component->base())}) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable via that pointer"_en_US,
+ *pointer);
+ }
flags.reset(DefinabilityFlag::PointerDefinition);
return WhyNotDefinableBase(at, scope, flags,
component->base().GetFirstSymbol(), false,
@@ -422,6 +447,10 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
}
return parser::Message{
at, "'%s' is not a definable pointer"_err_en_US, expr.AsFortran()};
+ } else if (const Symbol *pointer{FindProtectedTarget(expr)}) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable via that pointer"_en_US,
+ *pointer);
} else if (!evaluate::IsVariable(expr)) {
return parser::Message{
at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..6d3cf5b45d217 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -50,10 +50,12 @@ class PointerAssignmentChecker {
set_lhsType(TypeAndShape::Characterize(lhs, foldingContext_));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
+ set_isProtectedTarget(IsProtectedTarget(lhs));
}
PointerAssignmentChecker &set_lhsType(std::optional<TypeAndShape> &&);
PointerAssignmentChecker &set_isContiguous(bool);
PointerAssignmentChecker &set_isVolatile(bool);
+ PointerAssignmentChecker &set_isProtectedTarget(bool);
PointerAssignmentChecker &set_isBoundsRemapping(bool);
PointerAssignmentChecker &set_isAssumedRank(bool);
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
@@ -92,6 +94,7 @@ class PointerAssignmentChecker {
bool characterizedProcedure_{false};
bool isContiguous_{false};
bool isVolatile_{false};
+ bool isProtectedTarget_{false};
bool isBoundsRemapping_{false};
bool isAssumedRank_{false};
bool isRHSPointerActualArgument_{false};
@@ -117,6 +120,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isProtectedTarget(
+ bool isProtectedTarget) {
+ isProtectedTarget_ = isProtectedTarget;
+ return *this;
+}
+
PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
bool isBoundsRemapping) {
isBoundsRemapping_ = isBoundsRemapping;
@@ -190,6 +199,12 @@ bool PointerAssignmentChecker::Check(const evaluate::Expr<T> &x) {
}
bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
+ if (!isProtectedTarget_ && FindProtectedTarget(rhs)) {
+ // F2028 C870-C872.
+ Say("Target of a PROTECTED_TARGET pointer may not be associated with %s without PROTECTED_TARGET"_err_en_US,
+ description_);
+ return false;
+ }
if (HasVectorSubscript(rhs)) { // C1025
Say("An array section with a vector subscript may not be a pointer target"_err_en_US);
return false;
@@ -243,13 +258,18 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
"Target of CONTIGUOUS pointer association is not known to be contiguous"_warn_en_US);
}
}
- // Warn about undefinable data targets
- if (auto because{
- WhyNotDefinable(foldingContext_.messages().at(), scope_, {}, rhs)}) {
- if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
- "Pointer target is not a definable variable"_warn_en_US)}) {
- msg->Attach(std::move(because->set_severity(parser::Severity::Because)));
- return false;
+ // J3/26-007r1 C864 conflicts with 8.5.16 NOTE 1. Follow the US15
+ // example for PROTECTED_TARGET pointers; their targets cannot be
+ // defined through them. Preserve the ordinary-pointer warning.
+ if (!isProtectedTarget_) {
+ if (auto because{WhyNotDefinable(
+ foldingContext_.messages().at(), scope_, {}, rhs)}) {
+ if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
+ "Pointer target is not a definable variable"_warn_en_US)}) {
+ msg->Attach(
+ std::move(because->set_severity(parser::Severity::Because)));
+ return false;
+ }
}
}
return true;
@@ -619,6 +639,8 @@ bool CheckPointerAssignment(SemanticsContext &context, parser::CharBlock source,
.set_lhsType(common::Clone(lhs.type))
.set_isContiguous(lhs.attrs.test(DummyDataObject::Attr::Contiguous))
.set_isVolatile(lhs.attrs.test(DummyDataObject::Attr::Volatile))
+ .set_isProtectedTarget(
+ lhs.attrs.test(DummyDataObject::Attr::ProtectedTarget))
.set_isAssumedRank(isAssumedRank)
.set_isRHSPointerActualArgument(isPointerActualArgument)
.set_ignoreTKR(lhs.ignoreTKR)
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 3571a1de521f7..c7151b53034b2 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);
@@ -9327,7 +9332,8 @@ void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
// Don't call SetAttrsFromAssociation() for SELECT RANK.
Attrs selectorAttrs{
evaluate::GetAttrs(GetCurrentAssociation().selector.expr)};
- Attrs attrsToKeep{Attr::ASYNCHRONOUS, Attr::TARGET, Attr::VOLATILE};
+ Attrs attrsToKeep{Attr::ASYNCHRONOUS, Attr::PROTECTED_TARGET, Attr::TARGET,
+ Attr::VOLATILE};
if (const auto *rankValue{
std::get_if<parser::ScalarIntConstantExpr>(&x.u)}) {
// RANK(n)
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 48ff27f214649..d0f559cd87168 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -9,6 +9,7 @@
#include "flang/Parser/tools.h"
#include "flang/Common/indirection.h"
#include "flang/Evaluate/characteristics.h"
+#include "flang/Evaluate/tools.h"
#include "flang/Parser/dump-parse-tree.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parse-tree.h"
@@ -327,6 +328,43 @@ bool IsPointerDummy(const Symbol &symbol) {
return IsPointer(symbol) && IsDummy(symbol);
}
+const Symbol *FindProtectedTarget(
+ const evaluate::DataRef &dataRef, bool isPointerDefinition) {
+ auto symbols{evaluate::GetSymbolVector(dataRef)};
+ if (isPointerDefinition && !symbols.empty()) {
+ symbols.pop_back();
+ }
+ for (auto iter{symbols.rbegin()}; iter != symbols.rend(); ++iter) {
+ const Symbol &symbol{**iter};
+ if (IsPointer(symbol)) {
+ // F2028 9.4.2 p5: a component pointer's target is not a subobject
+ // of its containing object.
+ return IsProtectedTarget(symbol) ? &symbol : nullptr;
+ }
+ if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()};
+ assoc && assoc->expr()) {
+ return FindProtectedTarget(*assoc->expr());
+ }
+ }
+ return nullptr;
+}
+
+const Symbol *FindProtectedTarget(
+ const evaluate::Expr<evaluate::SomeType> &expr) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
+ return FindProtectedTarget(*dataRef);
+ }
+ if (const auto *ref{evaluate::UnwrapProcedureRef(expr)}) {
+ if (const Symbol *proc{ref->proc().GetSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*proc)};
+ result && IsProtectedTarget(*result)) {
+ return result;
+ }
+ }
+ }
+ return nullptr;
+}
+
bool IsBindCProcedure(const Symbol &original) {
const Symbol &symbol{original.GetUltimate()};
if (const auto *procDetails{symbol.detailsIf<ProcEntityDetails>()}) {
diff --git a/flang/test/Parser/protected-target.f90 b/flang/test/Parser/protected-target.f90
new file mode 100644
index 0000000000000..aa8f1991397be
--- /dev/null
+++ b/flang/test/Parser/protected-target.f90
@@ -0,0 +1,24 @@
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -ffixed-form -fdebug-unparse-no-sema %s 2>&1 | FileCheck %s
+! RUN: %flang_fc1 -fdebug-dump-parse-tree-no-sema %s 2>&1 | FileCheck %s --check-prefix=TREE
+
+ module m
+ integer, pointer, protected_target :: p
+! CHECK: INTEGER, POINTER, PROTECTED_TARGET :: p
+! TREE: AttrSpec -> ProtectedTarget
+ type t
+ integer, protected_target, pointer :: component
+! CHECK: INTEGER, PROTECTED_TARGET, POINTER :: component
+! TREE: ComponentAttrSpec -> ProtectedTarget
+ end type
+ contains
+ subroutine s
+ integer, pointer :: q, r
+ protected_target q
+! CHECK: PROTECTED_TARGET :: q
+! TREE: ProtectedTargetStmt
+ protected_target :: r
+! CHECK: PROTECTED_TARGET :: r
+! TREE: ProtectedTargetStmt
+ end subroutine
+ end module
diff --git a/flang/test/Semantics/Inputs/modfile89-a.f90 b/flang/test/Semantics/Inputs/modfile89-a.f90
new file mode 100644
index 0000000000000..acdee1af35e60
--- /dev/null
+++ b/flang/test/Semantics/Inputs/modfile89-a.f90
@@ -0,0 +1,20 @@
+subroutine reader
+ use protected_target_module
+ integer, pointer :: ordinary
+ integer, pointer, protected_target :: q
+ type(t) :: object
+ q => p
+ q => get()
+ object = t(p)
+ call take(q)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'component' is not definable via that pointer
+ object%component = 1
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => get()
+ !ERROR: Actual argument associated with POINTER dummy argument 'a=' must also be POINTER unless INTENT(IN)
+ call take(storage)
+end subroutine
diff --git a/flang/test/Semantics/modfile89.f90 b/flang/test/Semantics/modfile89.f90
new file mode 100644
index 0000000000000..4bac6ab608ec1
--- /dev/null
+++ b/flang/test/Semantics/modfile89.f90
@@ -0,0 +1,36 @@
+! RUN: %python %S/test_modfile.py %s %flang_fc1
+! RUN: mkdir -p %t
+! RUN: %flang_fc1 -fsyntax-only -module-dir %t %s
+! RUN: %python %S/test_errors.py %S/Inputs/modfile89-a.f90 %flang_fc1 -I %t
+
+module protected_target_module
+ integer, target :: storage
+ integer, pointer, protected_target :: p
+ type t
+ integer, pointer, protected_target :: component
+ end type
+contains
+ subroutine take(a)
+ integer, pointer, protected_target, intent(inout) :: a
+ end subroutine
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => storage
+ end function
+end module
+
+!Expect: protected_target_module.mod
+!module protected_target_module
+!integer(4),target::storage
+!integer(4),pointer,protected_target::p
+!type::t
+!integer(4),pointer,protected_target::component
+!end type
+!contains
+!subroutine take(a)
+!integer(4),intent(inout),pointer,protected_target::a
+!end
+!function get() result(r)
+!integer(4),pointer,protected_target::r
+!end
+!end
diff --git a/flang/test/Semantics/protected-target01.f90 b/flang/test/Semantics/protected-target01.f90
new file mode 100644
index 0000000000000..70403d4842051
--- /dev/null
+++ b/flang/test/Semantics/protected-target01.f90
@@ -0,0 +1,103 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Declaration and allocation constraints from J3/26-007r1.
+
+subroutine declarations
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ integer, protected_target :: not_a_pointer
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ integer, allocatable, protected_target :: allocatable_object
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ integer :: statement_object
+ protected_target statement_object
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ integer :: statement_object2
+ protected_target :: statement_object2
+ !ERROR: A PROTECTED_TARGET pointer may not be in a common block
+ integer, pointer, protected_target :: common_pointer
+ common /block/ common_pointer
+ integer, pointer :: p, q
+ protected_target p, q
+ integer :: forward_pointer
+ protected_target :: forward_pointer
+ pointer :: forward_pointer
+ type bad
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ integer, protected_target :: component
+ integer, pointer, protected_target :: good => null()
+ end type
+ nullify(p, q, forward_pointer)
+end subroutine
+
+subroutine common_components
+ type inner
+ sequence
+ integer, pointer, protected_target :: p
+ end type
+ type outer
+ sequence
+ type(inner) :: nested
+ end type
+ type(outer) :: object
+ !ERROR: Object 'object' in COMMON block /components/ has PROTECTED_TARGET pointer component 'p'
+ common /components/ object
+ type(outer), pointer :: ordinary
+ common /pointers/ ordinary
+end subroutine
+
+subroutine statement_constraint
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ real :: x
+ protected_target x
+end subroutine
+
+subroutine procedure_constraint
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ procedure(), pointer :: proc_pointer
+ protected_target :: proc_pointer
+end subroutine
+
+subroutine allocation
+ type t
+ integer, pointer, protected_target :: component
+ end type
+ type(t) :: object
+ integer, pointer, protected_target :: p, a(:)
+ integer, pointer :: ordinary
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(p)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(p, mold=1)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(integer :: p)
+ !ERROR: An ALLOCATE statement for a PROTECTED_TARGET pointer must have SOURCE=
+ allocate(object%component)
+ allocate(p, source=1)
+ allocate(a(2), source=1)
+ allocate(object%component, source=1)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'p' is a PROTECTED_TARGET pointer and may not be deallocated
+ deallocate(p)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: 'component' is a PROTECTED_TARGET pointer and may not be deallocated
+ deallocate(object%component)
+ nullify(p, a, object%component)
+ allocate(ordinary)
+ ordinary = 1
+ deallocate(ordinary)
+end subroutine
+
+subroutine intent_in(p, ordinary)
+ integer, pointer, protected_target, intent(in) :: p
+ integer, pointer, intent(in) :: ordinary
+ integer, target :: x
+ !ERROR: 'p' may not appear in NULLIFY
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ nullify(p)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ p => x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p = 2
+ ordinary = 2
+end subroutine
diff --git a/flang/test/Semantics/protected-target02.f90 b/flang/test/Semantics/protected-target02.f90
new file mode 100644
index 0000000000000..dea1919c89122
--- /dev/null
+++ b/flang/test/Semantics/protected-target02.f90
@@ -0,0 +1,146 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Target definition is distinct from pointer association (8.5.16 p2).
+
+module definitions
+ type node
+ integer :: value
+ integer :: array(2)
+ integer, pointer :: link
+ integer, pointer, protected_target :: read_only_link
+ integer, allocatable :: allocated
+ procedure(), pointer, nopass :: proc
+ end type
+contains
+ subroutine scalar(p)
+ integer, pointer, protected_target :: p
+ integer, target :: x
+ p => x
+ x = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p = 2
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ if (.false.) p = 3
+ !ERROR: Input variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ read *, p
+ !ERROR: 'p' may not be used as a DO variable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ do p = 1, 2
+ end do
+ associate(a => p)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ a = 2
+ end associate
+ nullify(p)
+ end subroutine
+
+ subroutine arrays(p, c, z)
+ integer, pointer, protected_target :: p(:)
+ character(:), pointer, protected_target :: c
+ complex, pointer, protected_target :: z
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p(1:2) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p([1,2]) = 2
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'c' is not definable via that pointer
+ c(1:1) = 'a'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'z' is not definable via that pointer
+ z%re = 1.
+ end subroutine
+
+ subroutine components(p, ordinary)
+ type(node), pointer, protected_target :: p
+ type(node), pointer :: ordinary
+ integer, target :: x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p%value = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p%array(1) = 1
+ ! A pointer component's separate target is not a subobject of p's target.
+ p%link = 1
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p%link => x
+ !ERROR: 'link' may not appear in NULLIFY
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ nullify(p%link)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'read_only_link' is not definable via that pointer
+ p%read_only_link = 1
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ allocate(p%allocated)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ deallocate(p%link)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p%proc => target_proc
+ ordinary%value = 1
+ ordinary%link => x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'read_only_link' is not definable via that pointer
+ ordinary%read_only_link = 1
+ ordinary%read_only_link => x
+ associate(a => p)
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ a%link => x
+ end associate
+ end subroutine
+
+ subroutine select_rank_definition(p)
+ integer, pointer, protected_target :: p(..)
+ select rank(p)
+ rank(0)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p = 1
+ nullify(p)
+ rank(1)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p(1) = 1
+ end select
+ end subroutine
+
+ subroutine select_type_definition(p)
+ class(*), pointer, protected_target :: p
+ select type(a => p)
+ type is(integer)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ a = 1
+ end select
+ end subroutine
+
+ subroutine status_variables(p, msg)
+ integer, pointer, protected_target :: p
+ character(:), pointer, protected_target :: msg
+ integer, allocatable :: a
+ !ERROR: STAT variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ allocate(a, stat=p)
+ !ERROR: ERRMSG variable 'msg' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'msg' is not definable via that pointer
+ deallocate(a, errmsg=msg)
+ !ERROR: IOSTAT variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ write(*,*,iostat=p) 1
+ !ERROR: Internal file variable 'msg' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'msg' is not definable via that pointer
+ write(msg,*) 1
+ end subroutine
+
+ subroutine target_proc
+ end subroutine
+end module
diff --git a/flang/test/Semantics/protected-target03.f90 b/flang/test/Semantics/protected-target03.f90
new file mode 100644
index 0000000000000..6b8338995e18e
--- /dev/null
+++ b/flang/test/Semantics/protected-target03.f90
@@ -0,0 +1,96 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! J3/26-007r1 C870-C871 preserve protection in assignments and constructors.
+
+module associations
+ type t
+ integer :: value
+ integer, pointer :: separate
+ end type
+ type writable
+ integer, pointer :: component
+ end type
+ type readable
+ integer, pointer, protected_target :: component
+ end type
+ integer, target :: storage
+ integer, parameter :: storage_constant = 1
+contains
+ subroutine assignment(p, a, c, object)
+ integer, pointer, protected_target :: p, a(:)
+ character(:), pointer, protected_target :: c
+ type(t), pointer, protected_target :: object
+ integer, pointer :: ordinary, ordinary_array(:)
+ integer, pointer, protected_target :: copy, copy_array(:)
+ character(:), pointer :: ordinary_character
+ type(writable) :: w
+ type(readable) :: r
+ copy => p
+ copy_array => a(1:2)
+ p => ordinary
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => p
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary_array' without PROTECTED_TARGET
+ ordinary_array => a(1:2)
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => a(1)
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary_character' without PROTECTED_TARGET
+ ordinary_character => c(1:2)
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => object%value
+ ordinary => object%separate
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'component' without PROTECTED_TARGET
+ w = writable(p)
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'component' without PROTECTED_TARGET
+ w = writable(a(1))
+ r = readable(p)
+ r = readable(a(1))
+ w = writable(object%separate)
+ !ERROR: Target associated with pointer 'component' must be a designator or a call to a pointer-valued function
+ w = writable((p))
+ associate(alias => a(1:2))
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary_array' without PROTECTED_TARGET
+ ordinary_array => alias
+ copy_array => alias
+ end associate
+ !ERROR: Target associated with pointer 'p' must be a designator or a call to a pointer-valued function
+ p => storage_constant
+ end subroutine
+
+ function read_only_result() result(p)
+ integer, pointer, protected_target :: p
+ p => storage
+ end function
+
+ function writable_result() result(p)
+ integer, pointer :: p
+ p => storage
+ end function
+
+ subroutine function_results
+ integer, pointer :: ordinary
+ integer, pointer, protected_target :: p
+ type(writable) :: w
+ type(readable) :: r
+ p => read_only_result()
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => read_only_result()
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'component' without PROTECTED_TARGET
+ w = writable(read_only_result())
+ r = readable(read_only_result())
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ read_only_result() = 1
+ !ERROR: Input variable 'read_only_result()' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ read *, read_only_result()
+ writable_result() = 1
+ read *, writable_result()
+ associate(a => read_only_result())
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ a = 1
+ !ERROR: Target of a PROTECTED_TARGET pointer may not be associated with pointer 'ordinary' without PROTECTED_TARGET
+ ordinary => a
+ end associate
+ end subroutine
+end module
diff --git a/flang/test/Semantics/protected-target04.f90 b/flang/test/Semantics/protected-target04.f90
new file mode 100644
index 0000000000000..1aa4c992ff496
--- /dev/null
+++ b/flang/test/Semantics/protected-target04.f90
@@ -0,0 +1,111 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! J3/26-007r1 C872-C874 apply even when a procedure never modifies its dummy.
+
+module calls
+ type t
+ integer :: value
+ integer, pointer :: separate
+ end type
+ integer, target :: storage
+contains
+ subroutine test(p, array, object)
+ integer, pointer, protected_target :: p, array(:)
+ type(t), pointer, protected_target :: object
+ integer, pointer :: ordinary
+ call read_pointer(p)
+ call read_pointer(ordinary)
+ call change_pointer(p)
+ call read_value(p)
+ call read_value(array(1))
+ call read_value(object%value)
+ call change_value(object%separate)
+ call no_intent((p))
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may not be associated with dummy argument 'a=' without PROTECTED_TARGET
+ call ordinary_pointer(p)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may not be associated with dummy argument 'a=' without PROTECTED_TARGET
+ call ordinary_pointer(array(1))
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may not be associated with dummy argument 'a=' without PROTECTED_TARGET
+ call ordinary_pointer(object%value)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may be associated only with a nonpointer dummy argument 'a=' that has INTENT(IN)
+ call change_value(p)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may be associated only with a nonpointer dummy argument 'a=' that has INTENT(IN)
+ call no_intent(p)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may be associated only with a nonpointer dummy argument 'a=' that has INTENT(IN)
+ call no_intent(array(1))
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may be associated only with a nonpointer dummy argument 'a=' that has INTENT(IN)
+ call value_no_intent(p)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target requires an explicit interface
+ call implicit(p)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target requires an explicit interface
+ call implicit_array(array(1:2))
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target requires an explicit interface
+ call implicit(object%value)
+ call implicit(object%separate)
+ call implicit((p))
+ associate(alias => array(1))
+ call read_value(alias)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may be associated only with a nonpointer dummy argument 'a=' that has INTENT(IN)
+ call no_intent(alias)
+ end associate
+ print *, associated(p), size(array), p + 1
+ p => null(p)
+ p => null(read_only_result())
+ call read_value(read_only_result())
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may be associated only with a nonpointer dummy argument 'a=' that has INTENT(IN)
+ call no_intent(read_only_result())
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target requires an explicit interface
+ call implicit(read_only_result())
+ end subroutine
+
+ subroutine read_pointer(a)
+ integer, pointer, protected_target, intent(in) :: a
+ end subroutine
+ subroutine change_pointer(a)
+ integer, pointer, protected_target, intent(out) :: a
+ nullify(a)
+ end subroutine
+ subroutine ordinary_pointer(a)
+ integer, pointer, intent(in) :: a
+ end subroutine
+ subroutine read_value(a)
+ integer, intent(in) :: a
+ end subroutine
+ subroutine change_value(a)
+ integer, intent(out) :: a
+ end subroutine
+ subroutine no_intent(a)
+ integer :: a
+ end subroutine
+ subroutine value_no_intent(a)
+ integer, value :: a
+ end subroutine
+ subroutine select_rank_calls(p)
+ integer, pointer, protected_target :: p(..)
+ select rank(p)
+ rank(0)
+ call read_value(p)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may not be associated with dummy argument 'a=' without PROTECTED_TARGET
+ call ordinary_pointer(p)
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target requires an explicit interface
+ call implicit(p)
+ rank(1)
+ call read_value(p(1))
+ !ERROR: A PROTECTED_TARGET pointer or a subobject of its target may be associated only with a nonpointer dummy argument 'a=' that has INTENT(IN)
+ call no_intent(p(1))
+ end select
+ end subroutine
+ subroutine null_allocatable(p, ordinary)
+ type with_allocatable
+ integer, allocatable :: a(:)
+ end type
+ type(with_allocatable), pointer, protected_target :: p
+ type(with_allocatable), pointer :: ordinary
+ type(with_allocatable) :: object
+ object = with_allocatable(null(p%a))
+ object = with_allocatable(null(ordinary%a))
+ end subroutine
+ function read_only_result() result(p)
+ integer, pointer, protected_target :: p
+ p => storage
+ end function
+end module
diff --git a/flang/test/Semantics/protected-target05.f90 b/flang/test/Semantics/protected-target05.f90
new file mode 100644
index 0000000000000..41d375a8cf8bb
--- /dev/null
+++ b/flang/test/Semantics/protected-target05.f90
@@ -0,0 +1,45 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Wpointer-to-undefinable
+! J3/26-007r1 C864 conflicts with 8.5.16 NOTE 1. Follow NOTE 1 for
+! PROTECTED_TARGET; retain the ordinary-pointer warning and target semantics.
+
+module protected_owner
+ integer, protected, target :: x
+ integer, protected, pointer :: ordinary_protected
+contains
+ subroutine owner
+ integer, pointer, protected_target :: p
+ p => x
+ nullify(p)
+ end subroutine
+end module
+
+subroutine use_protected
+ use protected_owner
+ integer, pointer :: ordinary
+ integer, target :: local
+ integer, pointer, protected_target :: p, q
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is protected in this scope
+ ordinary => x
+ p => x
+ q => p
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable via that pointer
+ p = 1
+ ordinary_protected = 1
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'ordinary_protected' is protected in this scope
+ ordinary_protected => local
+end subroutine
+
+subroutine intent_target(x)
+ integer, target, intent(in) :: x
+ integer, pointer, protected_target :: p
+ integer, pointer :: ordinary
+ p => x
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'x' is an INTENT(IN) dummy argument
+ ordinary => x
+ ordinary = 1
+ nullify(p, ordinary)
+end subroutine
diff --git a/flang/test/Semantics/protected-target06.f90 b/flang/test/Semantics/protected-target06.f90
new file mode 100644
index 0000000000000..633c8eee52928
--- /dev/null
+++ b/flang/test/Semantics/protected-target06.f90
@@ -0,0 +1,40 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Procedure characteristics retain PROTECTED_TARGET on dummies and results.
+
+module characteristics
+ integer, target :: storage
+contains
+ subroutine read(a)
+ integer, pointer, protected_target :: a
+ end subroutine
+ subroutine write(a)
+ integer, pointer :: a
+ end subroutine
+ function read_result() result(p)
+ integer, pointer, protected_target :: p
+ p => storage
+ end function
+ function write_result() result(p)
+ integer, pointer :: p
+ p => storage
+ end function
+
+ subroutine test
+ procedure(read), pointer :: reader
+ procedure(write), pointer :: writer
+ procedure(read_result), pointer :: read_function
+ procedure(write_result), pointer :: write_function
+ reader => read
+ writer => write
+ read_function => read_result
+ write_function => write_result
+ !ERROR: Procedure pointer 'reader' associated with incompatible procedure designator 'write': incompatible dummy argument #1: incompatible dummy data object attributes: ProtectedTarget
+ reader => write
+ !ERROR: Procedure pointer 'writer' associated with incompatible procedure designator 'read': incompatible dummy argument #1: incompatible dummy data object attributes: ProtectedTarget
+ writer => read
+ !ERROR: Function pointer 'read_function' associated with incompatible function designator 'write_result': function results have incompatible attributes
+ read_function => write_result
+ !ERROR: Function pointer 'write_function' associated with incompatible function designator 'read_result': function results have incompatible attributes
+ write_function => read_result
+ end subroutine
+end module
More information about the flang-commits
mailing list