[flang-commits] [flang] [flang] Add support for the PROTECTED_TARGET attribute (PR #232236)
Sairudra More via flang-commits
flang-commits at lists.llvm.org
Thu Oct 15 02:07:46 PDT 2026
https://github.com/Saieiei created https://github.com/llvm/llvm-project/pull/232236
The Fortran 2028 working draft (J3/26-007r1, 8.5.16 and 8.6.14) adds the
PROTECTED_TARGET attribute: the target of such a data pointer cannot be
defined through it, and C870-C874 keep that protection across pointer
assignment, structure constructors and argument association. Flang rejected
the attribute as a syntax error.
Parse the attribute, the component attribute and the statement, keep the
attribute in module files, and check C781, C866-C874 and C8109 in the existing
definability, pointer assignment, ALLOCATE/DEALLOCATE, COMMON and call checks,
including subobjects of the target.
Where the draft is unclear:
- C864 forbids a use-associated nonpointer PROTECTED data target, but NOTE 1
shows `p => x` as valid. This follows NOTE 1; -Wpointer-to-undefinable
(also enabled by -pedantic) still warns.
- The attribute is not a procedure characteristic (15.3.2.2), so interface
compatibility checks ignore it and a procedure pointer can drop the
protection.
- C867 is also applied to PROTECTED_TARGET pointer components of COMMON
objects (an interpretation following 25-179r1 S5), and C_F_POINTER rejects
a PROTECTED_TARGET FPTR (C872).
The optional NOTE 2 diagnostic is not implemented.
Assisted-by: GitHub Copilot
>From 5efa72fb753d69df3d91b87d4c6614331d0066cf Mon Sep 17 00:00:00 2001
From: Sairudra More <sairudra60 at gmail.com>
Date: Thu, 15 Oct 2026 04:07:32 -0500
Subject: [PATCH] [flang] Add support for the PROTECTED_TARGET attribute
The Fortran 2028 working draft (J3/26-007r1, 8.5.16 and 8.6.14) adds the
PROTECTED_TARGET attribute: the target of such a data pointer cannot be
defined through it, and C870-C874 keep that protection across pointer
assignment, structure constructors and argument association. Flang rejected
the attribute as a syntax error.
Parse the attribute, the component attribute and the statement, keep the
attribute in module files, and check C781, C866-C874 and C8109 in the existing
definability, pointer assignment, ALLOCATE/DEALLOCATE, COMMON and call checks,
including subobjects of the target.
Where the draft is unclear:
- C864 forbids a use-associated nonpointer PROTECTED data target, but NOTE 1
shows `p => x` as valid. This follows NOTE 1; -Wpointer-to-undefinable
(also enabled by -pedantic) still warns.
- The attribute is not a procedure characteristic (15.3.2.2), so interface
compatibility checks ignore it and a procedure pointer can drop the
protection.
- C867 is also applied to PROTECTED_TARGET pointer components of COMMON
objects (an interpretation following 25-179r1 S5), and C_F_POINTER rejects
a PROTECTED_TARGET FPTR (C872).
The optional NOTE 2 diagnostic is not implemented.
Assisted-by: GitHub Copilot
---
flang/docs/FortranStandardsSupport.md | 16 +++
flang/docs/ReleaseNotes.md | 3 +
.../include/flang/Evaluate/characteristics.h | 7 +-
flang/include/flang/Evaluate/tools.h | 8 ++
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 24 +++-
flang/include/flang/Semantics/attr.h | 4 +-
flang/lib/Evaluate/characteristics.cpp | 9 +-
flang/lib/Evaluate/tools.cpp | 39 ++++++
flang/lib/Parser/Fortran-parsers.cpp | 12 +-
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 | 9 ++
flang/lib/Semantics/check-call.cpp | 14 ++
flang/lib/Semantics/check-coarray.cpp | 27 ++++
flang/lib/Semantics/check-deallocate.cpp | 9 ++
flang/lib/Semantics/check-declarations.cpp | 30 +++-
flang/lib/Semantics/check-io.cpp | 7 +
flang/lib/Semantics/definable.cpp | 26 ++++
flang/lib/Semantics/pointer-assignment.cpp | 45 +++++-
flang/lib/Semantics/resolve-names.cpp | 16 ++-
flang/test/Parser/protected-target-fixed.f | 9 ++
flang/test/Parser/protected-target.f90 | 24 ++++
.../Semantics/OpenMP/protected-target.f90 | 44 ++++++
.../Semantics/modfile-protected-target.f90 | 59 ++++++++
.../Semantics/protected-target-legacy.f90 | 41 ++++++
.../Semantics/protected-target-positive.f90 | 71 ++++++++++
flang/test/Semantics/protected-target01.f90 | 80 +++++++++++
flang/test/Semantics/protected-target02.f90 | 69 +++++++++
flang/test/Semantics/protected-target03.f90 | 122 ++++++++++++++++
flang/test/Semantics/protected-target04.f90 | 120 ++++++++++++++++
flang/test/Semantics/protected-target05.f90 | 94 +++++++++++++
flang/test/Semantics/protected-target06.f90 | 131 ++++++++++++++++++
34 files changed, 1151 insertions(+), 27 deletions(-)
create mode 100644 flang/test/Parser/protected-target-fixed.f
create mode 100644 flang/test/Parser/protected-target.f90
create mode 100644 flang/test/Semantics/OpenMP/protected-target.f90
create mode 100644 flang/test/Semantics/modfile-protected-target.f90
create mode 100644 flang/test/Semantics/protected-target-legacy.f90
create mode 100644 flang/test/Semantics/protected-target-positive.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 dd8bda23cb495f..f72026c898a0b8 100644
--- a/flang/docs/FortranStandardsSupport.md
+++ b/flang/docs/FortranStandardsSupport.md
@@ -22,6 +22,22 @@ 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](https://j3-fortran.org/doc/year/26/26-007r1.pdf), sections
+8.5.16 and 8.6.14. It prevents defining a target through the pointer and requires
+protection to be preserved in pointer assignment, structure constructors and
+argument association. Pointer reassociation and `NULLIFY` remain allowed
+unless separately restricted; allocation requires `SOURCE=`, and deallocation
+is not allowed.
+
+For association with a use-associated nonpointer `PROTECTED` target, Flang
+follows the example in section 8.5.16 NOTE 1, which conflicts with C864 in that
+draft. This association is accepted without an error; `-pedantic` or
+`-Wpointer-to-undefinable` enables the warning "Pointer target is not a
+definable variable". `PROTECTED_TARGET` is not a procedure characteristic
+in this draft (15.3.2.2 and 15.3.3), so interface compatibility ignores it.
## Fortran 2023
See [document](F202X.md) for a brief discussion about the new features in Fortran 2023. The following table summarizes the
diff --git a/flang/docs/ReleaseNotes.md b/flang/docs/ReleaseNotes.md
index 609ca499da3965..870625862bf13b 100644
--- a/flang/docs/ReleaseNotes.md
+++ b/flang/docs/ReleaseNotes.md
@@ -29,6 +29,9 @@ page](https://llvm.org/releases/).
## Major New Features
+- Added front-end support for the Fortran 2028 draft `PROTECTED_TARGET`
+ data-pointer attribute and statement.
+
## Bug Fixes
- Fixed `fir::getTypeSizeAndAlignment` returning the wrong allocation size for
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 1ba0bf693c7630..dcdccc57761cbc 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -234,10 +234,13 @@ 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);
+ // F2028 15.3.2.2/15.3.3 do not make PROTECTED_TARGET a characteristic.
+ return (x - Attr::DeducedFromActual - Attr::ProtectedTarget) ==
+ (y - Attr::DeducedFromActual - Attr::ProtectedTarget);
}
DEFAULT_CONSTRUCTORS_AND_ASSIGNMENTS(DummyDataObject)
explicit DummyDataObject(const TypeAndShape &t) : type{t} {}
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 6f57e2d064aceb..f731519edb4043 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -1089,6 +1089,14 @@ const Expr<SomeType> *GetVariableSelector(const Symbol &);
// when none is found.
const Symbol *GetLastTarget(const SymbolVector &);
+// The PROTECTED_TARGET pointer through which an object is accessed, if any.
+// A later ordinary pointer component starts a different target (F2028 9.4.2p5).
+// For pointer association contexts, exclude the pointer being defined.
+const Symbol *GetProtectedTarget(
+ const DataRef &, bool isPointerDefinition = false);
+const Symbol *GetProtectedTarget(
+ const Expr<SomeType> &, bool isPointerDefinition = false);
+
// Collects all of the Symbols in an expression
template <typename A> semantics::UnorderedSymbolSet CollectSymbols(const A &);
extern template semantics::UnorderedSymbolSet CollectSymbols(
diff --git a/flang/include/flang/Parser/dump-parse-tree.h b/flang/include/flang/Parser/dump-parse-tree.h
index 7ca404663b4869..dbd613c11ee18c 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 207a5543ab7750..d4d4b51f51639b 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
@@ -374,6 +375,7 @@ EMPTY_CLASS(ErrorRecovery);
// intent-stmt | intrinsic-stmt | namelist-stmt | optional-stmt |
// pointer-stmt | protected-stmt | save-stmt | target-stmt |
// volatile-stmt | value-stmt | common-stmt | equivalence-stmt
+// F2028: also protected-target-stmt.
// Extension: (Cray) based POINTER statement
// Extension: CUDA data attribute statement
struct OtherSpecificationStmt {
@@ -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,9 @@ WRAPPER_CLASS(PointerStmt, std::list<PointerDecl>);
// R855 protected-stmt -> PROTECTED [::] entity-name-list
WRAPPER_CLASS(ProtectedStmt, std::list<Name>);
+// F2028 R863 protected-target-stmt -> PROTECTED_TARGET [::] variable-name-list
+WRAPPER_CLASS(ProtectedTargetStmt, std::list<Name>);
+
// R857 saved-entity -> object-name | proc-pointer-name | / common-block-name /
// R858 proc-pointer-name -> name
struct SavedEntity {
diff --git a/flang/include/flang/Semantics/attr.h b/flang/include/flang/Semantics/attr.h
index d8b323e88f6509..8a76ac6d50babc 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/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index 4b05a25fd8f58b..906bba87269253 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -281,8 +281,10 @@ llvm::raw_ostream &TypeAndShape::Dump(llvm::raw_ostream &o) const {
}
bool DummyDataObject::operator==(const DummyDataObject &that) const {
- return type == that.type && attrs == that.attrs && intent == that.intent &&
- coshape == that.coshape && cudaDataAttr == that.cudaDataAttr;
+ return type == that.type &&
+ (attrs - Attr::ProtectedTarget) == (that.attrs - Attr::ProtectedTarget) &&
+ intent == that.intent && coshape == that.coshape &&
+ cudaDataAttr == that.cudaDataAttr;
}
static bool IsOkWithSequenceAssociation(
@@ -372,7 +374,7 @@ bool DummyDataObject::IsCompatibleWith(const DummyDataObject &actual,
if (!IdenticalSignificantAttrs(attrs, actual.attrs)) {
if (whyNot) {
*whyNot = "incompatible dummy data object attributes";
- auto differences{attrs ^ actual.attrs};
+ auto differences{(attrs ^ actual.attrs) - Attr::ProtectedTarget};
auto sep{": "s};
differences.IterateOverMembers([&](DummyDataObject::Attr x) {
*whyNot += sep + std::string{EnumToString(x)};
@@ -439,6 +441,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
{Attr::VALUE, DummyDataObject::Attr::Value},
{Attr::VOLATILE, DummyDataObject::Attr::Volatile},
{Attr::POINTER, DummyDataObject::Attr::Pointer},
+ {Attr::PROTECTED_TARGET, DummyDataObject::Attr::ProtectedTarget},
{Attr::TARGET, DummyDataObject::Attr::Target},
});
result->intent = GetIntent(symbol.attrs());
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 0010221083d1e5..da3469ec9c90de 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1177,6 +1177,45 @@ const Symbol *GetLastTarget(const SymbolVector &symbols) {
return iter == end ? nullptr : &**iter;
}
+const Symbol *GetProtectedTarget(
+ const DataRef &dataRef, bool isPointerDefinition) {
+ SymbolVector symbols{GetSymbolVector(dataRef)};
+ if (isPointerDefinition && !symbols.empty()) {
+ symbols.pop_back();
+ }
+ for (auto iter{symbols.rbegin()}; iter != symbols.rend(); ++iter) {
+ const Symbol &symbol{iter->get().GetUltimate()};
+ if (const auto *association{
+ symbol.detailsIf<semantics::AssocEntityDetails>()};
+ association && association->expr()) {
+ // GetSymbolVector() does not expand pointer-valued function selectors.
+ return GetProtectedTarget(*association->expr());
+ }
+ if (IsPointer(symbol)) {
+ return symbol.attrs().test(semantics::Attr::PROTECTED_TARGET) ? &symbol
+ : nullptr;
+ }
+ }
+ return nullptr;
+}
+
+const Symbol *GetProtectedTarget(
+ const Expr<SomeType> &expr, bool isPointerDefinition) {
+ if (auto dataRef{ExtractDataRef(expr, true, true)}) {
+ return GetProtectedTarget(*dataRef, isPointerDefinition);
+ } else if (!isPointerDefinition) {
+ if (const auto *ref{UnwrapProcedureRef(expr)}) {
+ if (const Symbol *interface{ref->proc().GetInterfaceSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*interface)};
+ result && result->attrs().test(semantics::Attr::PROTECTED_TARGET)) {
+ return result;
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
struct CollectSymbolsHelper
: public SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet> {
using Base = SetTraverse<CollectSymbolsHelper, semantics::UnorderedSymbolSet>;
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 263ce9249a8b27..ca8c9eea330af1 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,10 @@ TYPE_PARSER(
TYPE_PARSER(
construct<ProtectedStmt>("PROTECTED" >> maybe("::"_tok) >> listOfNames))
+// F2028 R863 protected-target-stmt -> PROTECTED_TARGET [::] variable-name-list
+TYPE_PARSER(construct<ProtectedTargetStmt>(
+ "PROTECTED_TARGET" >> maybe("::"_tok) >> listOfNames))
+
// R856 save-stmt -> SAVE [[::] saved-entity-list]
TYPE_PARSER(construct<SaveStmt>(
"SAVE" >> defaulted(maybe("::"_tok) >>
diff --git a/flang/lib/Parser/misc-parsers.h b/flang/lib/Parser/misc-parsers.h
index 4a318e05bb4b8c..355ca918b32e3e 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 08283a8be35e3c..933214037ed2dd 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 a046c08e710c69..20513f6d376e46 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 e797b978c4bd33..e0341523129627 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -510,6 +510,15 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
"Entity in ALLOCATE statement must have the ALLOCATABLE or POINTER attribute"_err_en_US);
return false;
}
+ if (!allocateInfo_.gotSource && allocateObject_.typedExpr &&
+ allocateObject_.typedExpr->v &&
+ evaluate::IsObjectPointer(*allocateObject_.typedExpr->v) &&
+ evaluate::GetProtectedTarget(
+ *allocateObject_.typedExpr->v)) { // F2028 C869
+ context.Say(name_.source,
+ "Allocation of a PROTECTED_TARGET pointer requires SOURCE="_err_en_US);
+ return false;
+ }
bool gotSourceExprOrTypeSpec{allocateInfo_.gotMold ||
allocateInfo_.gotTypeSpec || allocateInfo_.gotSource};
if (hasDeferredTypeParameter_ && !gotSourceExprOrTypeSpec) {
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index feabf0cd33bf09..56589e80e3e116 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -67,6 +67,11 @@ void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
"%VAL argument must be a scalar numeric or logical expression"_err_en_US);
}
if (const auto *expr{arg.UnwrapExpr()}) {
+ if (evaluate::GetProtectedTarget(*expr)) { // F2028 C873
+ messages.Say(
+ "PROTECTED_TARGET pointer or subobject '%s' requires an explicit interface"_err_en_US,
+ expr->AsFortran());
+ }
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
}
@@ -830,6 +835,15 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// Definability checking
// Problems with polymorphism are caught in the callee's definition.
if (scope) {
+ if (!dummyIsPointer && dummy.intent != common::Intent::In &&
+ // Intrinsic dummies default to INTENT(IN) (J3/26-007r1 17.2.1p3).
+ !(intrinsic && dummy.intent == common::Intent::Default) &&
+ evaluate::GetProtectedTarget(actual)) { // F2028 C874
+ messages.Say(
+ "PROTECTED_TARGET pointer or subobject '%s' may be associated only with an INTENT(IN) nonpointer %s"_err_en_US,
+ actual.AsFortran(), dummyName);
+ return;
+ }
std::optional<parser::MessageFixedText> undefinableMessage;
DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
if (dummy.intent == common::Intent::InOut) {
diff --git a/flang/lib/Semantics/check-coarray.cpp b/flang/lib/Semantics/check-coarray.cpp
index 00b97162ff0d4e..f9a2227755e90c 100644
--- a/flang/lib/Semantics/check-coarray.cpp
+++ b/flang/lib/Semantics/check-coarray.cpp
@@ -11,6 +11,7 @@
#include "flang/Common/indirection.h"
#include "flang/Evaluate/check-expression.h"
#include "flang/Evaluate/expression.h"
+#include "flang/Evaluate/tools.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parse-tree.h"
#include "flang/Parser/tools.h"
@@ -97,6 +98,19 @@ class ChangeTeamBodyEnforce {
parser::CharBlock changeTeamSourcePosition_;
};
+template <typename T>
+static void CheckProtectedTargetDefinition(
+ SemanticsContext &context, const T &x) {
+ if (const auto *expr{GetExpr(context, x)};
+ expr && evaluate::GetProtectedTarget(*expr)) {
+ auto at{parser::FindSourceLocation(x)};
+ if (auto whyNot{WhyNotDefinable(at, context.FindScope(at),
+ {DefinabilityFlag::AllowEventLockOrNotifyType}, *expr)}) {
+ context.Say(std::move(*whyNot));
+ }
+ }
+}
+
template <typename T>
static void CheckTeamType(
SemanticsContext &context, const T &x, bool mustBeVariable = false) {
@@ -108,6 +122,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);
}
}
}
@@ -115,6 +131,7 @@ static void CheckTeamType(
static void CheckTeamStat(
SemanticsContext &context, const parser::ImageSelectorSpec::Stat &stat) {
const auto &var{parser::UnwrapRef<parser::Variable>(stat)};
+ CheckProtectedTargetDefinition(context, var);
if (parser::GetCoindexedNamedObject(var)) {
context.Say(parser::FindSourceLocation(var), // C931
"Image selector STAT variable must not be a coindexed "
@@ -177,6 +194,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);
}
}
}
@@ -285,6 +304,7 @@ static void CheckEventWaitSpecList(SemanticsContext &context,
void CoarrayChecker::Leave(const parser::NotifyWaitStmt &x) {
const auto ¬ifyVar{std::get<parser::Scalar<parser::Variable>>(x.t)};
+ CheckProtectedTargetDefinition(context_, notifyVar);
if (const auto *expr{GetExpr(context_, notifyVar)}) {
if (ExtractCoarrayRef(expr)) {
@@ -358,6 +378,9 @@ void CoarrayChecker::Leave(const parser::LockStmt &x) {
} else {
CHECK(std::holds_alternative<
parser::Scalar<parser::Logical<parser::Variable>>>(lockStat.u));
+ CheckProtectedTargetDefinition(context_,
+ std::get<parser::Scalar<parser::Logical<parser::Variable>>>(
+ lockStat.u));
if (gotAcquired) {
context_.Say(parser::FindSourceLocation(lockStat),
"Multiple ACQUIRED_LOCK specifiers"_err_en_US);
@@ -383,6 +406,10 @@ void CoarrayChecker::Leave(const parser::ImageSelector &imageSelector) {
if (const auto *stat{std::get_if<parser::ImageSelectorSpec::Stat>(
&imageSelectorSpec.u)}) {
CheckTeamStat(context_, *stat);
+ } else if (const auto *notify{
+ std::get_if<parser::ImageSelectorSpec::Notify>(
+ &imageSelectorSpec.u)}) {
+ CheckProtectedTargetDefinition(context_, *notify);
}
}
}
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index c93b940aa69edb..407b4ad1a0fde8 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -9,9 +9,11 @@
#include "check-deallocate.h"
#include "check-allocate.h"
#include "definable.h"
+#include "flang/Evaluate/tools.h"
#include "flang/Evaluate/type.h"
#include "flang/Parser/message.h"
#include "flang/Parser/parse-tree.h"
+#include "flang/Parser/tools.h"
#include "flang/Semantics/tools.h"
#include <optional>
@@ -53,6 +55,13 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
}
for (const parser::AllocateObject &allocateObject :
std::get<std::list<parser::AllocateObject>>(deallocateStmt.t)) {
+ if (const auto *expr{GetExpr(context_, allocateObject)}; expr &&
+ evaluate::IsObjectPointer(*expr) &&
+ evaluate::GetProtectedTarget(*expr)) { // F2028 C868
+ context_.Say(parser::GetLastName(allocateObject).source,
+ "A PROTECTED_TARGET pointer may not be deallocated"_err_en_US);
+ continue;
+ }
parser::CharBlock source;
common::visit(
common::visitors{
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 2abefd381850ad..d1eb5b94673cc9 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -314,6 +314,14 @@ void CheckHelper::Check(const Symbol &symbol) {
messages_.Say(
"An entity may not have the ASYNCHRONOUS attribute unless it is a variable"_err_en_US);
}
+ if (symbol.attrs().test(Attr::PROTECTED_TARGET) &&
+ !IsObjectPointer(&symbol)) {
+ // 25-182r1 specifies this attribute for named data pointers and data
+ // pointer components; the draft has no numbered constraint for a
+ // type-declaration attr-spec.
+ messages_.Say(
+ "An entity with the PROTECTED_TARGET attribute must be a data pointer"_err_en_US);
+ }
if (symbol.attrs().HasAny({Attr::INTENT_IN, Attr::INTENT_INOUT,
Attr::INTENT_OUT, Attr::OPTIONAL, Attr::VALUE}) &&
!IsDummy(symbol)) {
@@ -347,6 +355,12 @@ 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)) {
+ 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 +634,18 @@ void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
derived->typeSymbol()),
*ref);
}
+ if (!IsPointer(*ref)) {
+ if (const Symbol *pointer{
+ FindUltimateComponent(*derived, [](const Symbol &component) {
+ return component.attrs().test(Attr::PROTECTED_TARGET);
+ })}) { // Interpret F2028 C867 to include pointer components.
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "COMMON block /%s/ may not contain a PROTECTED_TARGET pointer component '%s'"_err_en_US,
+ symbol.name(), pointer->name()),
+ *pointer);
+ }
+ }
}
}
}
@@ -4177,7 +4203,9 @@ void SubprogramMatchHelper::CheckDummyDataObject(const Symbol &symbol1,
const Symbol &symbol2, const DummyDataObject &obj1,
const DummyDataObject &obj2) {
if (!CheckSameIntent(symbol1, symbol2, obj1.intent, obj2.intent)) {
- } else if (!CheckSameAttrs(symbol1, symbol2, obj1.attrs, obj2.attrs)) {
+ } else if (!CheckSameAttrs(symbol1, symbol2,
+ obj1.attrs - DummyDataObject::Attr::ProtectedTarget,
+ obj2.attrs - DummyDataObject::Attr::ProtectedTarget)) {
} else if (!obj1.type.type().IsEquivalentTo(obj2.type.type())) {
Say(symbol1, symbol2,
"Dummy argument '%s' has type %s; the corresponding argument in the interface body has distinct type %s"_err_en_US,
diff --git a/flang/lib/Semantics/check-io.cpp b/flang/lib/Semantics/check-io.cpp
index bc9181592aeb5e..8549219e21186e 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 if (const auto *iolength{
+ std::get_if<parser::InquireStmt::Iolength>(&stmt.u)}) {
+ const auto &var{std::get<parser::ScalarIntVariable>(iolength->t)};
+ if (const auto *expr{GetExpr(context_, var)};
+ expr && evaluate::GetProtectedTarget(*expr)) {
+ CheckForDefinableVariable(var, "IOLENGTH"); // F2028 C866, 20.6.7
+ }
}
Done();
}
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index d6a654683001ff..f5d8d9182b4098 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -23,6 +23,13 @@ static parser::Message BlameSymbol(parser::CharBlock at,
return message;
}
+static parser::Message BlameProtectedTarget(
+ parser::CharBlock at, const Symbol &pointer) {
+ return BlameSymbol(at,
+ "The target of PROTECTED_TARGET pointer '%s' is not definable"_en_US,
+ pointer);
+}
+
static bool IsPointerDummyOfPureFunction(const Symbol &x) {
return IsPointerDummy(x) && FindPureProcedureContaining(x.owner()) &&
x.owner().symbol() && IsFunction(*x.owner().symbol());
@@ -253,6 +260,11 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
static std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
const Scope &scope, DefinabilityFlags flags,
const evaluate::DataRef &dataRef) {
+ if (const Symbol *pointer{evaluate::GetProtectedTarget(
+ dataRef, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ // F2028 C866, 8.5.16p2
+ return BlameProtectedTarget(at, *pointer);
+ }
auto whyNotBase{
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
@@ -270,6 +282,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{
+ evaluate::GetProtectedTarget(evaluate::DataRef{original},
+ flags.test(DefinabilityFlag::PointerDefinition))}) {
+ // F2028 C866, 8.5.16p2
+ return BlameProtectedTarget(at, *pointer);
+ }
auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
/*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
if (!whyNotBase || !whyNotBase->IsFatal()) {
@@ -412,6 +430,11 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
}
if (const auto *component{procDesignator->GetComponent()}) {
flags.reset(DefinabilityFlag::PointerDefinition);
+ if (const Symbol *pointer{
+ evaluate::GetProtectedTarget(component->base())}) {
+ // F2028 C866, 8.5.16p2
+ return BlameProtectedTarget(at, *pointer);
+ }
return WhyNotDefinableBase(at, scope, flags,
component->base().GetFirstSymbol(), false,
DefinesComponentPointerTarget(component->base(), flags));
@@ -425,6 +448,9 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
} else if (!evaluate::IsVariable(expr)) {
return parser::Message{
at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
+ } else if (const Symbol *pointer{evaluate::GetProtectedTarget(expr)}) {
+ // F2028 C866, 8.5.16p2
+ return BlameProtectedTarget(at, *pointer);
}
return portabilityWarning;
}
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b48..212ff037888b6b 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -50,10 +50,13 @@ class PointerAssignmentChecker {
set_lhsType(TypeAndShape::Characterize(lhs, foldingContext_));
set_isContiguous(lhs.attrs().test(Attr::CONTIGUOUS));
set_isVolatile(lhs.attrs().test(Attr::VOLATILE));
+ 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_isBoundsRemapping(bool);
PointerAssignmentChecker &set_isAssumedRank(bool);
PointerAssignmentChecker &set_pointerComponentLHS(const Symbol *);
@@ -92,6 +95,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 +121,12 @@ PointerAssignmentChecker &PointerAssignmentChecker::set_isVolatile(
return *this;
}
+PointerAssignmentChecker &PointerAssignmentChecker::set_isProtectedTarget(
+ bool isProtectedTarget) {
+ isProtectedTarget_ = isProtectedTarget;
+ return *this;
+}
+
PointerAssignmentChecker &PointerAssignmentChecker::set_isBoundsRemapping(
bool isBoundsRemapping) {
isBoundsRemapping_ = isBoundsRemapping;
@@ -207,6 +217,16 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
if (lhs_ && IsProcedure(*lhs_)) {
return true;
}
+ if (!isProtectedTarget_) { // F2028 C870-C872
+ if (const Symbol *pointer{evaluate::GetProtectedTarget(rhs)}) {
+ if (auto *msg{Say(
+ "%s must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer '%s'"_err_en_US,
+ description_, pointer->name())}) {
+ evaluate::AttachDeclaration(msg, *pointer);
+ }
+ return false;
+ }
+ }
if (const auto *pureProc{FindPureProcedureContaining(scope_)}) {
if (pointerComponentLHS_) { // F'2023 C15104(4) is a hard error
if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) {
@@ -243,13 +263,22 @@ 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;
+ // Follow F2028 8.5.16 NOTE 1 despite C864: accept a PROTECTED_TARGET
+ // pointer's association with a use-associated nonpointer PROTECTED target,
+ // retaining the opt-in warning. Other undefinable-target reasons are silent
+ // for PROTECTED_TARGET pointers.
+ const Symbol *base{GetFirstSymbol(rhs)};
+ if (!isProtectedTarget_ ||
+ (base && IsProtected(base->GetUltimate()) &&
+ IsUseAssociated(*base, scope_) && !IsPointer(base->GetUltimate()))) {
+ 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 +648,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 3571a1de521f70..f307a53bdf7950 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)) {
@@ -9325,6 +9331,8 @@ void ConstructVisitor::Post(const parser::SelectRankCaseStmt::Rank &x) {
SetTypeFromAssociation(*symbol);
auto &details{symbol->get<AssocEntityDetails>()};
// Don't call SetAttrsFromAssociation() for SELECT RANK.
+ // J3/26-007r1 11.1.12.3p3 lists only ALLOCATABLE/POINTER/TARGET,
+ // but the associate name stands for the pointer selector.
Attrs selectorAttrs{
evaluate::GetAttrs(GetCurrentAssociation().selector.expr)};
Attrs attrsToKeep{Attr::ASYNCHRONOUS, Attr::TARGET, Attr::VOLATILE};
@@ -9334,7 +9342,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 +9355,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/test/Parser/protected-target-fixed.f b/flang/test/Parser/protected-target-fixed.f
new file mode 100644
index 00000000000000..23fce4252fc7cc
--- /dev/null
+++ b/flang/test/Parser/protected-target-fixed.f
@@ -0,0 +1,9 @@
+! RUN: %flang_fc1 -ffixed-form -fdebug-unparse-no-sema %s | FileCheck %s
+ subroutine s
+ integer p,q
+ pointer p,q
+ protected_target p
+ protected_target::q
+ end
+! CHECK: PROTECTED_TARGET :: p
+! CHECK: PROTECTED_TARGET :: q
diff --git a/flang/test/Parser/protected-target.f90 b/flang/test/Parser/protected-target.f90
new file mode 100644
index 00000000000000..fe0cd202f6c9a1
--- /dev/null
+++ b/flang/test/Parser/protected-target.f90
@@ -0,0 +1,24 @@
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s | FileCheck %s --check-prefix=UNPARSE
+! RUN: %flang_fc1 -fdebug-dump-parse-tree-no-sema %s | FileCheck %s --check-prefix=TREE
+
+module m
+ integer, pointer, protected_target :: p
+ type t
+ integer, protected_target, pointer :: c
+ end type
+contains
+ subroutine s
+ integer, pointer :: a, b
+ protected_target a
+ protected_target :: b
+ end subroutine
+end module
+
+! UNPARSE: INTEGER, POINTER, PROTECTED_TARGET :: p
+! UNPARSE: INTEGER, PROTECTED_TARGET, POINTER :: c
+! UNPARSE: PROTECTED_TARGET :: a
+! UNPARSE: PROTECTED_TARGET :: b
+! TREE: AttrSpec -> ProtectedTarget
+! TREE: ComponentAttrSpec -> ProtectedTarget
+! TREE: ProtectedTargetStmt
+! TREE: ProtectedTargetStmt
diff --git a/flang/test/Semantics/OpenMP/protected-target.f90 b/flang/test/Semantics/OpenMP/protected-target.f90
new file mode 100644
index 00000000000000..7c43fb00fe2979
--- /dev/null
+++ b/flang/test/Semantics/OpenMP/protected-target.f90
@@ -0,0 +1,44 @@
+! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp
+! PROTECTED_TARGET is preserved by explicit and implicit privatization.
+
+subroutine private_pointer(p, q, w)
+ integer, pointer, protected_target :: p, q
+ integer, pointer :: w
+
+ !$omp parallel private(p, w)
+ p => q
+ !ERROR: pointer 'w' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ w => p
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p = 1
+ !$omp end parallel
+end subroutine
+
+subroutine firstprivate_pointer(p, q, w)
+ integer, pointer, protected_target :: p, q
+ integer, pointer :: w
+
+ !$omp parallel firstprivate(p) private(w)
+ p => q
+ !ERROR: pointer 'w' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ w => p
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p = 1
+ !$omp end parallel
+end subroutine
+
+subroutine implicit_task_pointer(p, q, w)
+ integer, pointer, protected_target :: p, q
+ integer, pointer :: w
+
+ !$omp task
+ p => q
+ !ERROR: pointer 'w' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ w => p
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p = 1
+ !$omp end task
+end subroutine
diff --git a/flang/test/Semantics/modfile-protected-target.f90 b/flang/test/Semantics/modfile-protected-target.f90
new file mode 100644
index 00000000000000..fd2538fdafdab7
--- /dev/null
+++ b/flang/test/Semantics/modfile-protected-target.f90
@@ -0,0 +1,59 @@
+! RUN: split-file %s %t
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/m.f90
+! RUN: FileCheck %s --check-prefix=MOD < %t/protected_target_mod.mod
+! RUN: %flang_fc1 -fsyntax-only -I%t -J%t %t/good.f90
+! RUN: %python %S/test_errors.py %t/bad.f90 %flang_fc1 -I%t
+
+!--- m.f90
+module protected_target_mod
+ integer, pointer, protected_target :: p
+ type t
+ integer, pointer, protected_target :: component
+ end type
+contains
+ subroutine read_pointer(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => p
+ end function
+end module
+
+! MOD-DAG: integer(4),pointer,protected_target::p
+! MOD-DAG: integer(4),pointer,protected_target::component
+! MOD-DAG: integer(4),intent(in),pointer,protected_target::x
+! MOD-DAG: integer(4),pointer,protected_target::r
+
+!--- good.f90
+subroutine good
+ use protected_target_mod
+ integer, pointer, protected_target :: q
+ type(t) :: object
+ q => p
+ q => get()
+ object = t(p)
+ call read_pointer(p)
+ nullify(p, q)
+end subroutine
+
+!--- bad.f90
+subroutine bad
+ use protected_target_mod, only: renamed => p, get, t
+ integer, pointer :: ordinary
+ type(t) :: object
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ renamed = 1
+ !ERROR: pointer 'ordinary' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ ordinary => renamed
+ !ERROR: pointer 'ordinary' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'r'
+ ordinary => get()
+ !ERROR: Allocation of a PROTECTED_TARGET pointer requires SOURCE=
+ allocate(renamed)
+ !ERROR: A PROTECTED_TARGET pointer may not be deallocated
+ deallocate(renamed)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'component' is not definable
+ object%component = 1
+end subroutine
diff --git a/flang/test/Semantics/protected-target-legacy.f90 b/flang/test/Semantics/protected-target-legacy.f90
new file mode 100644
index 00000000000000..803c02eebaa730
--- /dev/null
+++ b/flang/test/Semantics/protected-target-legacy.f90
@@ -0,0 +1,41 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -Wpointer-to-undefinable
+! RUN: not %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck %s --check-prefix=DEFAULT --implicit-check-not=warning:
+! Ordinary-pointer INTENT(IN) and PROTECTED checks, including target warnings.
+! DEFAULT: error: 'in_pointer' may not appear in NULLIFY
+
+module legacy
+ integer, target, protected :: protected_value
+ integer, pointer, protected :: protected_pointer
+contains
+ subroutine owner
+ protected_pointer => protected_value
+ protected_value = 1
+ end subroutine
+end module
+
+subroutine test(in_pointer, in_target)
+ use legacy
+ integer, pointer, intent(in) :: in_pointer
+ integer, target, intent(in) :: in_target
+ integer, pointer :: ordinary
+ integer, pointer, protected_target :: readonly
+ in_pointer = 1
+ protected_pointer = 1
+ !ERROR: 'in_pointer' may not appear in NULLIFY
+ !BECAUSE: 'in_pointer' is an INTENT(IN) dummy argument
+ nullify(in_pointer)
+ !ERROR: 'protected_pointer' may not appear in NULLIFY
+ !BECAUSE: 'protected_pointer' is protected in this scope
+ nullify(protected_pointer)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'in_target' is an INTENT(IN) dummy argument
+ ordinary => in_target
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'protected_value' is protected in this scope
+ ordinary => protected_value
+ readonly => in_target
+ ! Follow F2028 8.5.16 NOTE 1 despite the draft's conflicting C864.
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'protected_value' is protected in this scope
+ readonly => protected_value
+end subroutine
diff --git a/flang/test/Semantics/protected-target-positive.f90 b/flang/test/Semantics/protected-target-positive.f90
new file mode 100644
index 00000000000000..827b306cc2ba89
--- /dev/null
+++ b/flang/test/Semantics/protected-target-positive.f90
@@ -0,0 +1,71 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %flang_fc1 -emit-hlfir -o /dev/null %s
+
+module protected_targets
+ integer, protected, target :: protected_value = 1
+ integer, target :: mutable_value = 1
+ integer, pointer, protected_target :: module_pointer
+ type t
+ integer, pointer, protected_target :: component
+ end type
+contains
+ function get() result(p)
+ integer, pointer, protected_target :: p
+ p => protected_value
+ end function
+ subroutine read_pointer(p)
+ integer, pointer, protected_target, intent(in) :: p
+ print *, p
+ end subroutine
+
+ subroutine keyword_as_name
+ integer :: protected_target
+ protected_target = 1
+ end subroutine
+ subroutine implicit_pointer_declaration
+ pointer p
+ protected_target p
+ end subroutine
+ subroutine reset_pointer(p)
+ integer, pointer, protected_target, intent(out) :: p
+ p => protected_value
+ end subroutine
+ subroutine read_value(x)
+ integer, intent(in) :: x
+ end subroutine
+end module
+
+subroutine test(x, ordinary_in)
+ use protected_targets
+ integer, target, intent(in) :: x
+ integer, pointer, intent(in) :: ordinary_in
+ integer, pointer, protected_target :: p, q
+ integer, pointer :: ordinary
+ integer, pointer :: statement1, statement2
+ protected_target statement1
+ protected_target :: statement2
+ type(t) :: object
+ p => x
+ q => p
+ p => null(p)
+ q => null(p)
+ ordinary => mutable_value
+ p => ordinary
+ ! Follow F2028 8.5.16 NOTE 1 despite the draft's conflicting C864.
+ p => protected_value
+ p => get()
+ module_pointer => p
+ statement1 => p
+ statement2 => statement1
+ object = t(p)
+ object%component => p
+ call read_pointer(p)
+ call reset_pointer(p)
+ call read_value(p)
+ call read_value(p + 1)
+ print *, associated(p), associated(p, protected_value), p
+ allocate(q, source=42)
+ nullify(p, q, module_pointer, object%component)
+ mutable_value = 2
+ ordinary_in = 2
+end subroutine
diff --git a/flang/test/Semantics/protected-target01.f90 b/flang/test/Semantics/protected-target01.f90
new file mode 100644
index 00000000000000..a571a8288e05f3
--- /dev/null
+++ b/flang/test/Semantics/protected-target01.f90
@@ -0,0 +1,80 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! F2028 C781, C867-C869 and C8109.
+
+subroutine declarations
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ integer, protected_target :: nonpointer
+ !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
+ procedure(real), pointer :: procedure_pointer
+ protected_target :: procedure_pointer
+ !ERROR: A PROTECTED_TARGET pointer may not be in a common block
+ integer, pointer, protected_target :: common_pointer
+ common /block/ common_pointer
+ type t
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ integer, protected_target :: component
+ end type
+end subroutine
+
+subroutine data_pointer_not_external
+ !ERROR: 'f' is a data object and may not be EXTERNAL
+ real, pointer, protected_target :: f
+ !ERROR: EXTERNAL attribute not allowed on 'f'
+ external f
+end subroutine
+
+subroutine common_component
+ type t
+ sequence
+ integer, pointer, protected_target :: component
+ end type
+ type(t) :: object
+ type(t), pointer :: ordinary_pointer
+ !ERROR: COMMON block /bad/ may not contain a PROTECTED_TARGET pointer component 'component'
+ common /bad/ object
+ common /good/ ordinary_pointer
+end subroutine
+
+subroutine statement_constraint
+ !ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+ integer :: nonpointer
+ protected_target :: nonpointer
+end subroutine
+
+!ERROR: An entity with the PROTECTED_TARGET attribute must be a data pointer
+function protected_function_name() result(r)
+ integer, pointer :: r
+ protected_target :: protected_function_name
+end function
+
+subroutine allocation
+ type t
+ integer, pointer, protected_target :: component
+ end type
+ type(t) :: object
+ integer, pointer, protected_target :: p, a(:)
+ integer, pointer :: ordinary
+ allocate(p, source=42)
+ allocate(a(2), source=[1, 2])
+ allocate(object%component, source=42)
+ allocate(ordinary)
+ deallocate(ordinary)
+ !ERROR: Allocation of a PROTECTED_TARGET pointer requires SOURCE=
+ allocate(p)
+ !ERROR: Allocation of a PROTECTED_TARGET pointer requires SOURCE=
+ allocate(p, mold=42)
+ !ERROR: Allocation of a PROTECTED_TARGET pointer requires SOURCE=
+ allocate(integer :: p)
+ !ERROR: Allocation of a PROTECTED_TARGET pointer requires SOURCE=
+ allocate(object%component)
+ !ERROR: A PROTECTED_TARGET pointer may not be deallocated
+ deallocate(p)
+ !ERROR: A PROTECTED_TARGET pointer may not be deallocated
+ deallocate(object%component)
+ nullify(p, a, object%component)
+end subroutine
diff --git a/flang/test/Semantics/protected-target02.f90 b/flang/test/Semantics/protected-target02.f90
new file mode 100644
index 00000000000000..37179136865cba
--- /dev/null
+++ b/flang/test/Semantics/protected-target02.f90
@@ -0,0 +1,69 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! F2028 C866, C870-C871 and 8.5.16p2.
+
+subroutine definitions
+ integer, target :: x(2)
+ integer, pointer, protected_target :: p(:)
+ integer, pointer :: w(:), scalar
+ character(4), pointer, protected_target :: text
+ character(:), pointer :: mutable_text
+ complex, pointer, protected_target :: z
+ real, pointer :: mutable_real
+ type mutable
+ integer, pointer :: component(:)
+ end type
+ type readonly
+ integer, pointer, protected_target :: component(:)
+ end type
+ type(mutable) :: m
+ type(readonly) :: r
+ p => x
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p(1) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ if (.false.) p(1:2) = 1
+ !ERROR: Input variable 'p' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ read *, p
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'text' is not definable
+ text(2:3) = 'ab'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'z' is not definable
+ z%re = 1.
+ !ERROR: pointer 'mutable_text' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'text'
+ mutable_text => text(2:3)
+ !ERROR: pointer 'mutable_real' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'z'
+ mutable_real => z%re
+ !ERROR: pointer 'w' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ w => p
+ !ERROR: pointer 'w' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ w => p(1:2)
+ !ERROR: pointer 'scalar' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ scalar => p(1)
+ !ERROR: pointer 'component' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ m = mutable(p)
+ !ERROR: pointer 'component' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ m = mutable(p(1:2))
+ r = readonly(p)
+ r = readonly(p(1:2))
+ r%component => p
+ p => r%component
+ x = 2
+ nullify(p, r%component)
+end subroutine
+
+subroutine intent_in(p)
+ integer, pointer, intent(in), protected_target :: p
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p = 1
+ !ERROR: 'p' may not appear in NULLIFY
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ nullify(p)
+end subroutine
diff --git a/flang/test/Semantics/protected-target03.f90 b/flang/test/Semantics/protected-target03.f90
new file mode 100644
index 00000000000000..303bde70989370
--- /dev/null
+++ b/flang/test/Semantics/protected-target03.f90
@@ -0,0 +1,122 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! F2028 C872-C874, including generic resolution and pointer function results.
+
+module calls
+ integer, target :: target
+ type record
+ integer :: value
+ end type
+ interface generic
+ module procedure ordinary_array, elemental_read
+ end interface
+ interface generic_values
+ module procedure no_intent_array, elemental_read
+ end interface
+contains
+ subroutine test(p, a, object, flag)
+ integer, pointer, protected_target :: p, a(:)
+ type(record), pointer, protected_target :: object
+ real, pointer, protected_target :: real_pointer
+ logical :: flag
+ integer, pointer :: ordinary
+ external implicit
+ !ERROR: PROTECTED_TARGET pointer or subobject 'real_pointer' may be associated only with an INTENT(IN) nonpointer dummy argument 'harvest='
+ call random_number(real_pointer)
+ !ERROR: PROTECTED_TARGET pointer or subobject 'p' requires an explicit interface
+ call implicit(p)
+ !ERROR: PROTECTED_TARGET pointer or subobject 'a(1_8:2_8:1_8)' requires an explicit interface
+ call implicit(a(1:2))
+ !ERROR: dummy argument 'x=' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ call ordinary_pointer(p)
+ !ERROR: dummy argument 'x=' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'a'
+ call ordinary_array(a(1:2))
+ !ERROR: dummy argument 'x=' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'object'
+ call ordinary_pointer(object%value)
+ !ERROR: PROTECTED_TARGET pointer or subobject 'p' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call no_intent(p)
+ !ERROR: PROTECTED_TARGET pointer or subobject 'a(1_8)' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call no_intent(a(1))
+ !ERROR: PROTECTED_TARGET pointer or subobject 'object%value' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call no_intent(object%value)
+ !ERROR: PROTECTED_TARGET pointer or subobject 'p' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call write_value(p)
+ !ERROR: PROTECTED_TARGET pointer or subobject 'p' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call update_value(p)
+ !ERROR: PROTECTED_TARGET pointer or subobject 'p' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call value_no_intent(p)
+ !ERROR: dummy argument 'x=' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'a'
+ call generic(a)
+ !ERROR: PROTECTED_TARGET pointer or subobject 'a' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call generic_values(a)
+ !ERROR: dummy argument 'x=' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ call ordinary_pointer((flag ? ordinary : p))
+ !ERROR: PROTECTED_TARGET pointer or subobject 'p' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call no_intent((flag ? ordinary : p))
+ call protected_pointer((flag ? ordinary : p))
+ call read_value(p)
+ call protected_pointer(p)
+ call protected_out(p)
+ call read_value(object%value)
+ call no_intent((p))
+ call no_intent(p + 1)
+ call implicit(p + 1)
+ call read_value(get())
+ call protected_pointer(get())
+ !ERROR: pointer 'ordinary' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'r'
+ ordinary => get()
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'r' is not definable
+ get() = 1
+ !ERROR: PROTECTED_TARGET pointer or subobject 'get()' requires an explicit interface
+ call implicit(get())
+ !ERROR: dummy argument 'x=' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'r'
+ call ordinary_pointer(get())
+ !ERROR: PROTECTED_TARGET pointer or subobject 'get()' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call no_intent(get())
+ end subroutine
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => target
+ end function
+ subroutine ordinary_pointer(x)
+ integer, pointer, intent(in) :: x
+ end subroutine
+ subroutine c_pointer(cptr, p)
+ use iso_c_binding, only: c_ptr, c_f_pointer
+ type(c_ptr) :: cptr
+ integer, pointer, protected_target :: p
+ !ERROR: dummy argument 'fptr=' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ call c_f_pointer(cptr, p)
+ end subroutine
+ subroutine ordinary_array(x)
+ integer, pointer, intent(in) :: x(:)
+ end subroutine
+ elemental subroutine elemental_read(x)
+ integer, intent(in) :: x
+ end subroutine
+ subroutine protected_pointer(x)
+ integer, pointer, protected_target, intent(in) :: x
+ end subroutine
+ subroutine protected_out(x)
+ integer, pointer, protected_target, intent(out) :: x
+ nullify(x)
+ end subroutine
+ subroutine no_intent(x)
+ integer :: x
+ end subroutine
+ subroutine no_intent_array(x)
+ integer :: x(:)
+ end subroutine
+ subroutine value_no_intent(x)
+ integer, value :: x
+ end subroutine
+ subroutine read_value(x)
+ integer, intent(in) :: x
+ end subroutine
+ subroutine write_value(x)
+ integer, intent(out) :: x
+ end subroutine
+ subroutine update_value(x)
+ integer, intent(inout) :: x
+ 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 00000000000000..12bb7da83d27a3
--- /dev/null
+++ b/flang/test/Semantics/protected-target04.f90
@@ -0,0 +1,120 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! Protection follows construct associations and subobjects, but an ordinary
+! pointer component's target is not a subobject (F2028 9.4.2p5).
+
+module associations
+ type node
+ integer :: value
+ integer, allocatable :: allocation
+ type(node), pointer :: link
+ type(node), pointer, protected_target :: readonly_link
+ procedure(sin), pointer, nopass :: callback
+ end type
+contains
+ subroutine nested(p, x)
+ type(node), pointer, protected_target :: p
+ type(node), target :: x
+ integer, pointer :: ordinary
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p%value = 1
+ !ERROR: pointer 'ordinary' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ ordinary => p%value
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ p%link => x
+ !ERROR: 'link' may not appear in NULLIFY
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ nullify(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
+ p%callback => sin
+ !ERROR: 'callback' may not appear in NULLIFY
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ nullify(p%callback)
+ !ERROR: Actual argument associated with INTENT(OUT) procedure pointer dummy argument 'callback=' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ call reset_callback(p%callback)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ allocate(p%allocation, source=1)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ allocate(p%link)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ deallocate(p%link)
+ p%link%value = 1
+ p%link%link => x
+ nullify(p%link%link)
+ p%link%callback => sin
+ nullify(p%link%callback)
+ ordinary => p%link%value
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'readonly_link' is not definable
+ p%link%readonly_link%value = 1
+ !ERROR: A PROTECTED_TARGET pointer may not be deallocated
+ deallocate(p%link%readonly_link)
+ end subroutine
+ subroutine associate_array(p)
+ integer, pointer, protected_target :: p(:)
+ integer, pointer :: ordinary(:)
+ external implicit
+ associate(a => p(1:2))
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ a = 1
+ !ERROR: pointer 'ordinary' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ ordinary => a
+ !ERROR: PROTECTED_TARGET pointer or subobject 'a' requires an explicit interface
+ call implicit(a)
+ associate(b => a)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ b(1) = 1
+ end associate
+ end associate
+ end subroutine
+ subroutine select_type(p)
+ class(node), pointer, protected_target :: p
+ select type(a => p)
+ type is(node)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ a%value = 1
+ a%link%value = 1
+ end select
+ end subroutine
+ subroutine select_rank(p)
+ integer, pointer, protected_target :: p(..)
+ integer, pointer, protected_target :: p2(:)
+ integer, pointer :: w(:)
+ select rank(a => p)
+ rank(1)
+ a => p2
+ !ERROR: pointer 'w' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'p'
+ w => a
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'p' is not definable
+ a(1) = 1
+ !ERROR: Allocation of a PROTECTED_TARGET pointer requires SOURCE=
+ allocate(a(2))
+ allocate(a(2), source=[1, 2])
+ nullify(a)
+ rank default
+ select rank(b => a)
+ rank(1)
+ b => p2
+ end select
+ !ERROR: PROTECTED_TARGET pointer or subobject 'a' may be associated only with an INTENT(IN) nonpointer dummy argument 'x='
+ call assumed_rank(a)
+ end select
+ end subroutine
+ subroutine assumed_rank(x)
+ integer :: x(..)
+ end subroutine
+ subroutine reset_callback(callback)
+ procedure(sin), pointer, intent(out) :: callback
+ nullify(callback)
+ end subroutine
+end module
diff --git a/flang/test/Semantics/protected-target05.f90 b/flang/test/Semantics/protected-target05.f90
new file mode 100644
index 00000000000000..6b40462a1fbac1
--- /dev/null
+++ b/flang/test/Semantics/protected-target05.f90
@@ -0,0 +1,94 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! F2028 C866: variable definition contexts other than assignment.
+
+subroutine controls(index, text, flag, indices, ordinary_in)
+ integer, pointer, protected_target :: index
+ integer, pointer, protected_target :: indices(:)
+ character(20), pointer, protected_target :: text
+ logical, pointer, protected_target :: flag
+ integer, intent(in) :: ordinary_in
+ integer, allocatable :: allocation
+ integer :: status
+ namelist /group/ index
+ !ERROR: 'index' may not be used as a DO variable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'index' is not definable
+ do index = 1, 2
+ end do
+ !ERROR: The target of PROTECTED_TARGET pointer 'index' is not definable
+ print *, (1, index = 1, 2)
+ !ERROR: Internal file variable 'text' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'text' is not definable
+ write(text, *) 1
+ !ERROR: IOSTAT variable 'index' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'index' is not definable
+ read(*, *, iostat=index) allocation
+ !ERROR: IOMSG variable 'text' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'text' is not definable
+ read(*, *, iomsg=text, iostat=status) allocation
+ !ERROR: EXIST variable 'flag' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'flag' is not definable
+ inquire(file='file', exist=flag)
+ !ERROR: IOLENGTH variable 'index' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'index' is not definable
+ inquire(iolength=index) allocation
+ !ERROR: IOLENGTH variable 'indices' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'indices' is not definable
+ inquire(iolength=indices(1)) allocation
+ inquire(iolength=status) allocation
+ inquire(iolength=ordinary_in) allocation
+ !ERROR: NEWUNIT variable 'index' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'index' is not definable
+ open(newunit=index, status='scratch')
+ !ERROR: STAT variable 'index' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'index' is not definable
+ allocate(allocation, stat=index)
+ !ERROR: ERRMSG variable 'text' is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'text' is not definable
+ deallocate(allocation, errmsg=text)
+ !ERROR: NAMELIST input group must not contain undefinable item 'index'
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'index' is not definable
+ read(*, nml=group)
+end subroutine
+
+subroutine notify_controls(nv)
+ use iso_fortran_env, only: notify_type
+ type(notify_type), pointer, protected_target :: nv
+ integer, save :: remote[*]
+ !ERROR: The target of PROTECTED_TARGET pointer 'nv' is not definable
+ !ERROR: The notify-variable must be a coarray
+ notify wait(nv)
+ !ERROR: The target of PROTECTED_TARGET pointer 'nv' is not definable
+ remote[1, notify=nv] = 1
+end subroutine
+
+subroutine image_controls(team, event, lockvar, acquired)
+ use iso_fortran_env, only: team_type, event_type, lock_type
+ type(team_type), pointer, protected_target :: team
+ type(event_type), pointer, protected_target :: event
+ type(lock_type), pointer, protected_target :: lockvar
+ logical, pointer, protected_target :: acquired
+ type(lock_type) :: ordinary_lock[*]
+ save ordinary_lock
+ !ERROR: The target of PROTECTED_TARGET pointer 'team' is not definable
+ form team(1, team)
+ !ERROR: The target of PROTECTED_TARGET pointer 'event' is not definable
+ event post(event)
+ !ERROR: The target of PROTECTED_TARGET pointer 'event' is not definable
+ event wait(event)
+ !ERROR: Lock variable is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'lockvar' is not definable
+ lock(lockvar)
+ !ERROR: Lock variable is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'lockvar' is not definable
+ unlock(lockvar)
+ !ERROR: The target of PROTECTED_TARGET pointer 'acquired' is not definable
+ lock(ordinary_lock, acquired_lock=acquired)
+end subroutine
+
+subroutine image_selector(index)
+ integer, pointer, protected_target :: index
+ integer :: remote[*]
+ save remote
+ !ERROR: The target of PROTECTED_TARGET pointer 'index' is not definable
+ remote[1, stat=index] = 1
+end subroutine
diff --git a/flang/test/Semantics/protected-target06.f90 b/flang/test/Semantics/protected-target06.f90
new file mode 100644
index 00000000000000..ade6e72f9c2334
--- /dev/null
+++ b/flang/test/Semantics/protected-target06.f90
@@ -0,0 +1,131 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+! F2028 15.3.2.2/15.3.3 do not make PROTECTED_TARGET a characteristic.
+! Interface compatibility ignores it; call checking retains it.
+
+module characteristics
+ integer, target :: target
+ interface
+ subroutine pointer_interface(x)
+ integer, pointer, protected_target :: x
+ end subroutine
+ subroutine ordinary_pointer_interface(x)
+ integer, pointer :: x
+ end subroutine
+ function function_interface() result(r)
+ integer, pointer, protected_target :: r
+ end function
+ function ordinary_function_interface() result(r)
+ integer, pointer :: r
+ end function
+ module subroutine separate(protected_arg, ordinary_arg, protected_proc, &
+ ordinary_proc, protected_result_proc, ordinary_result_proc)
+ integer, pointer, protected_target :: protected_arg
+ integer, pointer :: ordinary_arg
+ procedure(pointer_interface) :: protected_proc
+ procedure(ordinary_pointer_interface) :: ordinary_proc
+ procedure(function_interface) :: protected_result_proc
+ procedure(ordinary_function_interface) :: ordinary_result_proc
+ end subroutine
+ module function separate_protected_result() result(r)
+ integer, pointer, protected_target :: r
+ end function
+ module function separate_ordinary_result() result(r)
+ integer, pointer :: r
+ end function
+ end interface
+ type base
+ contains
+ procedure, nopass :: sub => protected_subroutine
+ procedure, nopass :: func => protected_function
+ end type
+ type, extends(base) :: derived
+ contains
+ procedure, nopass :: sub => ordinary_subroutine
+ procedure, nopass :: func => ordinary_function
+ end type
+ type ordinary_base
+ contains
+ procedure, nopass :: sub => ordinary_subroutine
+ procedure, nopass :: func => ordinary_function
+ end type
+ type, extends(ordinary_base) :: protected_derived
+ contains
+ procedure, nopass :: sub => protected_subroutine
+ procedure, nopass :: func => protected_function
+ end type
+contains
+ subroutine test
+ procedure(pointer_interface), pointer :: subprogram
+ procedure(ordinary_pointer_interface), pointer :: ordinary_subprogram
+ procedure(function_interface), pointer :: function_pointer
+ procedure(ordinary_function_interface), pointer :: ordinary_function_pointer
+ integer, pointer :: ordinary
+ subprogram => protected_subroutine
+ function_pointer => protected_function
+ subprogram => ordinary_subroutine
+ function_pointer => ordinary_function
+ ordinary_subprogram => ordinary_subroutine
+ ordinary_subprogram => protected_subroutine
+ ordinary_function_pointer => ordinary_function
+ ordinary_function_pointer => protected_function
+ call take_protected_pointer(ordinary_subroutine)
+ call take_ordinary_pointer(protected_subroutine)
+ call take_protected_function(ordinary_function)
+ call take_ordinary_function(protected_function)
+ associate(a => protected_function())
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: The target of PROTECTED_TARGET pointer 'r' is not definable
+ a = 1
+ !ERROR: pointer 'ordinary' must have the PROTECTED_TARGET attribute when associated with the target of PROTECTED_TARGET pointer 'r'
+ ordinary => a
+ end associate
+ end subroutine
+ subroutine protected_subroutine(x)
+ integer, pointer, protected_target :: x
+ end subroutine
+ subroutine ordinary_subroutine(x)
+ integer, pointer :: x
+ end subroutine
+ function protected_function() result(r)
+ integer, pointer, protected_target :: r
+ r => target
+ end function
+ function ordinary_function() result(r)
+ integer, pointer :: r
+ r => target
+ end function
+ subroutine take_protected_pointer(proc)
+ procedure(pointer_interface) :: proc
+ end subroutine
+ subroutine take_ordinary_pointer(proc)
+ procedure(ordinary_pointer_interface) :: proc
+ end subroutine
+ subroutine take_protected_function(proc)
+ procedure(function_interface) :: proc
+ end subroutine
+ subroutine take_ordinary_function(proc)
+ procedure(ordinary_function_interface) :: proc
+ end subroutine
+end module
+
+submodule(characteristics) bodies
+contains
+ module subroutine separate(protected_arg, ordinary_arg, protected_proc, &
+ ordinary_proc, protected_result_proc, ordinary_result_proc)
+ integer, pointer :: protected_arg
+ integer, pointer, protected_target :: ordinary_arg
+ procedure(ordinary_pointer_interface) :: protected_proc
+ procedure(pointer_interface) :: ordinary_proc
+ procedure(ordinary_function_interface) :: protected_result_proc
+ procedure(function_interface) :: ordinary_result_proc
+ end subroutine
+ module function separate_protected_result() result(r)
+ integer, pointer :: r
+ r => target
+ end function
+ module function separate_ordinary_result() result(r)
+ integer, pointer, protected_target :: r
+ r => target
+ end function
+end submodule
More information about the flang-commits
mailing list