[flang-commits] [flang] [flang] Add the PROTECTED_TARGET attribute from the Fortran 2028 draft (PR #231228)
via flang-commits
flang-commits at lists.llvm.org
Mon Oct 12 10:06:11 PDT 2026
https://github.com/arusv81 created https://github.com/llvm/llvm-project/pull/231228
The Fortran 2028 working draft (J3/26-007r1, 8.5.16 and 8.6.14) adds the
PROTECTED_TARGET attribute for data pointers: the target cannot be defined
through such a pointer. Flang did not parse it.
Parse the attribute, the component attribute and the statement, keep the
attribute in module files, and report C781, C866-C874 and C8109 as errors.
Defining the target through the pointer or an associate name for it is
rejected; the pointer itself can still be pointer-assigned, nullified and
allocated with SOURCE=. The C872 and C874 checks run only on the resolved
procedure, so generic resolution does not change, and skip the right-hand side
of a defined assignment (15.4.3.4.3). OpenMP LASTPRIVATE checks such a pointer
as a pointer definition.
Some readings of the draft are open. Associate names other than RANK DEFAULT
do not carry the attribute for C870-C874. An ordinary pointer component
reached through the pointer can have its target defined but cannot be
pointer-assigned. The attribute is not a dummy argument characteristic
(15.3.2.2). C_F_POINTER rejects a PROTECTED_TARGET FPTR. A use-associated
nonpointer PROTECTED target keeps the optional -Wpointer-to-undefinable
warning despite 8.5.16 NOTE 1. The draft syntax gets no portability warning,
and as for INTENT(IN), INQUIRE(IOLENGTH=) and a few other definition contexts
are unchecked.
>From 0b4a4a2da3dd1116c9f6a5a10be72237f4f526f3 Mon Sep 17 00:00:00 2001
From: arusv81 <arusv81 at gmail.com>
Date: Mon, 12 Oct 2026 12:05:13 -0500
Subject: [PATCH] [flang] Add the PROTECTED_TARGET attribute from the Fortran
2028 draft
The Fortran 2028 working draft (J3/26-007r1, 8.5.16 and 8.6.14) adds the
PROTECTED_TARGET attribute for data pointers: the target cannot be defined
through such a pointer. Flang did not parse it.
Parse the attribute, the component attribute and the statement, keep the
attribute in module files, and report C781, C866-C874 and C8109 as errors.
Defining the target through the pointer or an associate name for it is
rejected; the pointer itself can still be pointer-assigned, nullified and
allocated with SOURCE=. The C872 and C874 checks run only on the resolved
procedure, so generic resolution does not change, and skip the right-hand side
of a defined assignment (15.4.3.4.3). OpenMP LASTPRIVATE checks such a pointer
as a pointer definition.
Some readings of the draft are open. Associate names other than RANK DEFAULT
do not carry the attribute for C870-C874. An ordinary pointer component
reached through the pointer can have its target defined but cannot be
pointer-assigned. The attribute is not a dummy argument characteristic
(15.3.2.2). C_F_POINTER rejects a PROTECTED_TARGET FPTR. A use-associated
nonpointer PROTECTED target keeps the optional -Wpointer-to-undefinable
warning despite 8.5.16 NOTE 1. The draft syntax gets no portability warning,
and as for INTENT(IN), INQUIRE(IOLENGTH=) and a few other definition contexts
are unchecked.
---
flang/docs/FortranStandardsSupport.md | 5 +
.../include/flang/Evaluate/characteristics.h | 2 +
flang/include/flang/Parser/dump-parse-tree.h | 2 +
flang/include/flang/Parser/parse-tree.h | 25 +-
flang/include/flang/Semantics/attr.h | 4 +-
flang/include/flang/Semantics/expression.h | 5 +-
flang/include/flang/Semantics/tools.h | 10 +
flang/lib/Evaluate/characteristics.cpp | 1 +
flang/lib/Parser/Fortran-parsers.cpp | 14 +-
flang/lib/Parser/misc-parsers.h | 2 +
flang/lib/Parser/program-parsers.cpp | 6 +-
flang/lib/Parser/unparse.cpp | 4 +
flang/lib/Semantics/check-allocate.cpp | 5 +-
flang/lib/Semantics/check-call.cpp | 58 +++-
flang/lib/Semantics/check-call.h | 9 +-
flang/lib/Semantics/check-deallocate.cpp | 8 +-
flang/lib/Semantics/check-declarations.cpp | 15 +
flang/lib/Semantics/check-omp-structure.cpp | 13 +-
flang/lib/Semantics/definable.cpp | 55 +++-
flang/lib/Semantics/definable.h | 2 +
flang/lib/Semantics/expression.cpp | 25 +-
flang/lib/Semantics/pointer-assignment.cpp | 32 +-
flang/lib/Semantics/resolve-names.cpp | 5 +
flang/lib/Semantics/tools.cpp | 88 ++++++
flang/test/Parser/protected-target.f90 | 29 ++
.../test/Semantics/CUDA/protected-target.cuf | 24 ++
.../Semantics/OpenMP/protected-target.f90 | 116 +++++++
.../Semantics/modfile-protected-target.f90 | 79 +++++
flang/test/Semantics/protected-target01.f90 | 89 ++++++
flang/test/Semantics/protected-target02.f90 | 299 ++++++++++++++++++
flang/test/Semantics/protected-target03.f90 | 140 ++++++++
flang/test/Semantics/protected-target04.f90 | 210 ++++++++++++
flang/test/Semantics/protected-target05.f90 | 170 ++++++++++
33 files changed, 1493 insertions(+), 58 deletions(-)
create mode 100644 flang/test/Parser/protected-target.f90
create mode 100644 flang/test/Semantics/CUDA/protected-target.cuf
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-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
diff --git a/flang/docs/FortranStandardsSupport.md b/flang/docs/FortranStandardsSupport.md
index dd8bda23cb495..fbf9bfd142b52 100644
--- a/flang/docs/FortranStandardsSupport.md
+++ b/flang/docs/FortranStandardsSupport.md
@@ -22,6 +22,11 @@ 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
+
+| Feature | Status | Comments |
+|---------|--------|----------|
+| PROTECTED_TARGET attribute and statement | P | Parsing, module-file persistence, and semantic checks based on J3/26-007r1. Some variable definition contexts remain unchecked, also for INTENT(IN). |
## 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/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index 1ba0bf693c763..8b5b2aaa577ec 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -262,6 +262,8 @@ struct DummyDataObject {
Attrs attrs;
common::IgnoreTKRSet ignoreTKR;
std::optional<common::CUDADataAttr> cudaDataAttr;
+ // Needed for argument checks, but not a characteristic in F2028 15.3.2.2.
+ bool isProtectedTarget{false};
};
// 15.3.2.3
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..6926681e38bf6 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -173,6 +173,7 @@ struct ParameterStmt; // R851
struct OldParameterStmt;
struct PointerStmt; // R853
struct ProtectedStmt; // R855
+struct ProtectedTargetStmt; // F2028 R863
struct SaveStmt; // R856
struct TargetStmt; // R859
struct ValueStmt; // R861
@@ -386,9 +387,10 @@ struct OtherSpecificationStmt {
common::Indirection<IntentStmt>, common::Indirection<IntrinsicStmt>,
common::Indirection<NamelistStmt>, common::Indirection<OptionalStmt>,
common::Indirection<PointerStmt>, common::Indirection<ProtectedStmt>,
- common::Indirection<SaveStmt>, common::Indirection<TargetStmt>,
- common::Indirection<ValueStmt>, common::Indirection<VolatileStmt>,
- common::Indirection<CommonStmt>, common::Indirection<EquivalenceStmt>,
+ common::Indirection<ProtectedTargetStmt>, common::Indirection<SaveStmt>,
+ common::Indirection<TargetStmt>, common::Indirection<ValueStmt>,
+ common::Indirection<VolatileStmt>, common::Indirection<CommonStmt>,
+ common::Indirection<EquivalenceStmt>,
common::Indirection<BasedPointerStmt>,
common::Indirection<CUDAAttributesStmt>>
u;
@@ -995,10 +997,12 @@ struct ComponentArraySpec {
// access-spec | ALLOCATABLE |
// CODIMENSION lbracket coarray-spec rbracket |
// CONTIGUOUS | DIMENSION ( component-array-spec ) | POINTER |
+// (F2028 R749) PROTECTED_TARGET |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE | UNIFIED
EMPTY_CLASS(Allocatable);
EMPTY_CLASS(Pointer);
EMPTY_CLASS(Contiguous);
+EMPTY_CLASS(ProtectedTarget);
// CUDA-data-attr [( IMPLICIT )]
// The (IMPLICIT) qualifier marks an attribute that the compiler applied on the
// user's behalf (e.g. an unattributed ALLOCATABLE under -gpu=mem:managed)
@@ -1013,7 +1017,8 @@ struct CUDADataAttrSpec {
struct ComponentAttrSpec {
UNION_CLASS_BOILERPLATE(ComponentAttrSpec);
std::variant<AccessSpec, Allocatable, CoarraySpec, Contiguous,
- ComponentArraySpec, Pointer, CUDADataAttrSpec, ErrorRecovery>
+ ComponentArraySpec, Pointer, ProtectedTarget, CUDADataAttrSpec,
+ ErrorRecovery>
u;
};
@@ -1405,8 +1410,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 |
-// VALUE | VOLATILE |
+// PROTECTED | PROTECTED_TARGET | RANK ( scalar-int-constant-expr ) |
+// SAVE | TARGET | VALUE | VOLATILE |
// (CUDA) CONSTANT | DEVICE | MANAGED | PINNED | SHARED | TEXTURE
EMPTY_CLASS(Asynchronous);
EMPTY_CLASS(External);
@@ -1422,8 +1427,8 @@ struct AttrSpec {
UNION_CLASS_BOILERPLATE(AttrSpec);
std::variant<AccessSpec, Allocatable, Asynchronous, CoarraySpec, Contiguous,
ArraySpec, External, IntentSpec, Intrinsic, LanguageBindingSpec, Optional,
- Parameter, Pointer, Protected, RankClause, Save, Target, Value, Volatile,
- CUDADataAttrSpec>
+ Parameter, Pointer, Protected, ProtectedTarget, RankClause, Save, Target,
+ Value, Volatile, CUDADataAttrSpec>
u;
};
@@ -1616,6 +1621,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/expression.h b/flang/include/flang/Semantics/expression.h
index bcee8d65b58e2..e6a3afd14921a 100644
--- a/flang/include/flang/Semantics/expression.h
+++ b/flang/include/flang/Semantics/expression.h
@@ -366,8 +366,9 @@ class ExpressionAnalyzer {
std::optional<CalleeAndArguments> AnalyzeProcedureComponentRef(
const parser::ProcComponentRef &, ActualArguments &&, bool isSubroutine);
- std::optional<characteristics::Procedure> CheckCall(
- parser::CharBlock, const ProcedureDesignator &, ActualArguments &);
+ std::optional<characteristics::Procedure> CheckCall(parser::CharBlock,
+ const ProcedureDesignator &, ActualArguments &,
+ bool isDefinedAssignment = false);
using AdjustActuals =
std::optional<std::function<bool(const Symbol &, ActualArguments &)>>;
const Symbol *ResolveForward(const Symbol &);
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index d91a7d11a38c9..7be8fcf84ba7d 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -178,6 +178,16 @@ inline bool IsIntentOut(const Symbol &symbol) {
inline bool IsProtected(const Symbol &symbol) {
return symbol.attrs().test(Attr::PROTECTED);
}
+// Find the rightmost pointer part-name and return it if it has
+// PROTECTED_TARGET. For pointer definition, omit the last part-name to check
+// the containing object. By default, follow associate selectors; otherwise
+// follow only RANK DEFAULT selectors. Unless the pointer itself is being
+// defined, pointer-valued function references are checked via their result
+// symbols.
+const Symbol *FindProtectedTargetPointer(const evaluate::DataRef &,
+ bool isPointerDefinition = false, bool followAssociations = true);
+const Symbol *FindProtectedTargetPointer(const SomeExpr &,
+ bool isPointerDefinition = false, bool followAssociations = true);
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..886e477bfcfd9 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -443,6 +443,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
});
result->intent = GetIntent(symbol.attrs());
result->ignoreTKR = GetIgnoreTKR(symbol);
+ result->isProtectedTarget = symbol.attrs().test(Attr::PROTECTED_TARGET);
if (object) {
result->cudaDataAttr = object->cudaDataAttr();
if (!result->cudaDataAttr &&
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index 263ce9249a8b2..9b7e2beb0adfe 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 |
+// (F2028 R749) PROTECTED_TARGET |
// CUDA-data-attr
TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(allocatable) ||
@@ -476,6 +477,7 @@ TYPE_PARSER(construct<ComponentAttrSpec>(accessSpec) ||
construct<ComponentAttrSpec>(contiguous) ||
construct<ComponentAttrSpec>("DIMENSION" >> componentArraySpec) ||
construct<ComponentAttrSpec>(pointer) ||
+ construct<ComponentAttrSpec>(protectedTargetAttr) ||
extension<LanguageFeature::CUDA>(
construct<ComponentAttrSpec>(Parser<CUDADataAttrSpec>{})) ||
construct<ComponentAttrSpec>(recovery(
@@ -742,8 +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 |
-// VALUE | VOLATILE |
+// PROTECTED | PROTECTED_TARGET | RANK ( scalar-int-constant-expr ) |
+// SAVE | TARGET | VALUE | VOLATILE |
// CUDA-data-attr
TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
construct<AttrSpec>(allocatable) ||
@@ -756,7 +758,8 @@ TYPE_PARSER(construct<AttrSpec>(accessSpec) ||
construct<AttrSpec>(construct<Intrinsic>("INTRINSIC"_tok)) ||
construct<AttrSpec>(languageBindingSpec) || construct<AttrSpec>(optional) ||
construct<AttrSpec>(construct<Parameter>("PARAMETER"_tok)) ||
- construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedAttr) ||
+ construct<AttrSpec>(pointer) || construct<AttrSpec>(protectedTargetAttr) ||
+ construct<AttrSpec>(protectedAttr) ||
construct<AttrSpec>("RANK" >>
construct<RankClause>(parenthesized(scalarIntConstantExpr))) ||
construct<AttrSpec>(save) ||
@@ -1050,6 +1053,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..adf32807ac3e2 100644
--- a/flang/lib/Parser/misc-parsers.h
+++ b/flang/lib/Parser/misc-parsers.h
@@ -49,6 +49,8 @@ constexpr auto allocatable{construct<Allocatable>("ALLOCATABLE"_tok)};
constexpr auto contiguous{construct<Contiguous>("CONTIGUOUS"_tok)};
constexpr auto optional{construct<Optional>("OPTIONAL"_tok)};
constexpr auto pointer{construct<Pointer>("POINTER"_tok)};
+constexpr auto protectedTargetAttr{
+ construct<ProtectedTarget>("PROTECTED_TARGET"_tok)};
constexpr auto protectedAttr{construct<Protected>("PROTECTED"_tok)};
constexpr auto save{construct<Save>("SAVE"_tok)};
diff --git a/flang/lib/Parser/program-parsers.cpp b/flang/lib/Parser/program-parsers.cpp
index 08283a8be35e3..1b09fcd134d68 100644
--- a/flang/lib/Parser/program-parsers.cpp
+++ b/flang/lib/Parser/program-parsers.cpp
@@ -215,8 +215,9 @@ TYPE_CONTEXT_PARSER("specification construct"_en_US,
// 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 |
-// volatile-stmt | value-stmt | common-stmt | equivalence-stmt |
+// pointer-stmt | protected-stmt | protected-target-stmt |
+// save-stmt | target-stmt | volatile-stmt | value-stmt |
+// common-stmt | equivalence-stmt |
// (CUDA) CUDA-attributes-stmt
TYPE_PARSER(first(
construct<OtherSpecificationStmt>(indirect(Parser<AccessStmt>{})),
@@ -232,6 +233,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..a0a1c40993105 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -695,7 +695,10 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
name_.source, subpScope, flags, *allocateObject_.typedExpr->v)}) {
context
.Say(name_.source,
- "Name in ALLOCATE statement is not definable"_err_en_US)
+ ultimate_->attrs().test(Attr::PROTECTED_TARGET) &&
+ !allocateInfo_.gotSource
+ ? "Object in ALLOCATE statement may not be allocated"_err_en_US
+ : "Name in ALLOCATE statement is not definable"_err_en_US)
.Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
return false;
}
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index feabf0cd33bf0..4f398647f0f2d 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -38,6 +38,22 @@ void CheckImplicitInterfaceArgKeywords(
}
}
+bool CheckImplicitInterfaceArgProtectedTarget(
+ const evaluate::ActualArgument &arg, parser::ContextualMessages &messages) {
+ auto restorer{
+ messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
+ if (const auto *expr{arg.UnwrapExpr()}) {
+ if (const Symbol *pointer{FindProtectedTargetPointer(
+ *expr, false, /*followAssociations=*/false)}) { // F2028 C873
+ evaluate::SayWithDeclaration(messages, *pointer,
+ "PROTECTED_TARGET pointer '%s' or its subobject may not be passed to a procedure with an implicit interface"_err_en_US,
+ pointer->name());
+ return false;
+ }
+ }
+ return true;
+}
+
void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
parser::ContextualMessages &messages, SemanticsContext &context) {
CheckImplicitInterfaceArgKeywords(arg, messages);
@@ -66,6 +82,7 @@ void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
messages.Say(
"%VAL argument must be a scalar numeric or logical expression"_err_en_US);
}
+ CheckImplicitInterfaceArgProtectedTarget(arg, messages);
if (const auto *expr{arg.UnwrapExpr()}) {
if (const Symbol *base{GetFirstSymbol(*expr)}) {
context.NoteDefinedSymbol(GetAssociationRoot(*base));
@@ -389,7 +406,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
bool allowActualArgumentConversions, bool extentErrors,
const characteristics::Procedure &procedure,
const evaluate::ActualArgument &arg,
- const characteristics::DummyArgument &dummyArg) {
+ const characteristics::DummyArgument &dummyArg,
+ bool isDefinedAssignmentRHS) {
// Basic type & rank checking
parser::ContextualMessages &messages{foldingContext.messages()};
@@ -399,6 +417,26 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
dummy.attrs.test(characteristics::DummyDataObject::Attr::Allocatable)};
bool dummyIsPointer{
dummy.attrs.test(characteristics::DummyDataObject::Attr::Pointer)};
+ bool badProtectedTarget{false};
+ // A null scope suppresses these constraints during generic resolution.
+ if (const Symbol *pointer{scope && !isDefinedAssignmentRHS
+ ? FindProtectedTargetPointer(
+ actual, false, /*followAssociations=*/false)
+ : nullptr}) {
+ if (dummyIsPointer && !dummy.isProtectedTarget) { // F2028 C872
+ evaluate::SayWithDeclaration(messages, *pointer,
+ "POINTER %s must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer '%s' or its subobject"_err_en_US,
+ dummyName, pointer->name());
+ badProtectedTarget = true;
+ } else if (!dummyIsPointer && dummy.intent != common::Intent::In &&
+ !(intrinsic && dummy.intent == common::Intent::Default)) {
+ // F2028 C874; an intrinsic's default intent is IN (17.2.1p3).
+ evaluate::SayWithDeclaration(messages, *pointer,
+ "Nonpointer %s must have INTENT(IN) to accept PROTECTED_TARGET pointer '%s' or its subobject"_err_en_US,
+ dummyName, pointer->name());
+ badProtectedTarget = true;
+ }
+ }
bool dummyIsAllocatableOrPointer{dummyIsAllocatable || dummyIsPointer};
allowActualArgumentConversions &= !dummyIsAllocatableOrPointer;
bool typesCompatibleWithIgnoreTKR{
@@ -829,7 +867,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// Definability checking
// Problems with polymorphism are caught in the callee's definition.
- if (scope) {
+ if (scope && !badProtectedTarget) {
std::optional<parser::MessageFixedText> undefinableMessage;
DefinabilityFlags flags{DefinabilityFlag::PolymorphicOkInPure};
if (dummy.intent == common::Intent::InOut) {
@@ -1040,7 +1078,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
// 15.5.2.7 -- dummy is POINTER
if (dummyIsPointer) {
if (actualIsPointer || dummy.intent == common::Intent::In) {
- if (scope) {
+ if (scope && !badProtectedTarget) {
semantics::CheckPointerAssignment(context, messages.at(), dummyName,
dummy, actual, *scope,
/*isAssumedRank=*/dummyIsAssumedRank, actualIsPointer);
@@ -1638,7 +1676,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
const characteristics::Procedure &proc, SemanticsContext &context,
const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
bool allowActualArgumentConversions, bool extentErrors,
- bool ignoreImplicitVsExplicit) {
+ bool ignoreImplicitVsExplicit, bool isDefinedAssignmentRHS) {
evaluate::FoldingContext &foldingContext{context.foldingContext()};
auto &messages{foldingContext.messages()};
std::string dummyName{"dummy argument"};
@@ -1671,7 +1709,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
CheckExplicitDataArg(object, dummyName, expr, *type,
isElemental, context, foldingContext, scope, intrinsic,
allowActualArgumentConversions, extentErrors, proc, arg,
- dummy);
+ dummy, isDefinedAssignmentRHS);
} else if (object.type.type().IsTypelessIntrinsicArgument() &&
IsBOZLiteral(expr)) {
// ok
@@ -2575,7 +2613,7 @@ parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
evaluate::ActualArguments &actuals, SemanticsContext &context,
const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
bool allowActualArgumentConversions, bool extentErrors,
- bool ignoreImplicitVsExplicit) {
+ bool ignoreImplicitVsExplicit, bool isDefinedAssignment) {
evaluate::FoldingContext &foldingContext{context.foldingContext()};
parser::ContextualMessages &messages{foldingContext.messages()};
parser::Messages buffer;
@@ -2590,7 +2628,7 @@ parser::Messages CheckExplicitInterface(const characteristics::Procedure &proc,
if (actual) {
CheckExplicitInterfaceArg(*actual, dummy, proc, context, scope, intrinsic,
allowActualArgumentConversions, extentErrors,
- ignoreImplicitVsExplicit);
+ ignoreImplicitVsExplicit, isDefinedAssignment && index == 2);
} else if (!dummy.IsOptional()) {
if (dummy.name.empty()) {
messages.Say(
@@ -2736,8 +2774,8 @@ bool CheckWindowsIntrinsic(
bool CheckArguments(const characteristics::Procedure &proc,
evaluate::ActualArguments &actuals, SemanticsContext &context,
const Scope &scope, bool treatingExternalAsImplicit,
- bool ignoreImplicitVsExplicit,
- const evaluate::SpecificIntrinsic *intrinsic) {
+ bool ignoreImplicitVsExplicit, const evaluate::SpecificIntrinsic *intrinsic,
+ bool isDefinedAssignment) {
bool explicitInterface{proc.HasExplicitInterface()};
evaluate::FoldingContext foldingContext{context.foldingContext()};
parser::ContextualMessages &messages{foldingContext.messages()};
@@ -2763,7 +2801,7 @@ bool CheckArguments(const characteristics::Procedure &proc,
if (explicitInterface) {
auto explicitBuffer{CheckExplicitInterface(proc, actuals, context, &scope,
intrinsic, allowArgumentConversions,
- /*extentErrors=*/true, ignoreImplicitVsExplicit)};
+ /*extentErrors=*/true, ignoreImplicitVsExplicit, isDefinedAssignment)};
if (!explicitBuffer.empty()) {
if (treatingExternalAsImplicit && explicitBuffer.AnyFatalError()) {
// Combine all messages into one warning
diff --git a/flang/lib/Semantics/check-call.h b/flang/lib/Semantics/check-call.h
index 8caf71479fe5a..683331558f2a4 100644
--- a/flang/lib/Semantics/check-call.h
+++ b/flang/lib/Semantics/check-call.h
@@ -30,6 +30,10 @@ class SemanticsContext;
void CheckImplicitInterfaceArgKeywords(
const evaluate::ActualArgument &, parser::ContextualMessages &);
+// Check F2028 C873. Returns false if a PROTECTED_TARGET actual is diagnosed.
+bool CheckImplicitInterfaceArgProtectedTarget(
+ const evaluate::ActualArgument &, parser::ContextualMessages &);
+
// Check constraints on actual arguments for procedures with implicit
// interfaces.
void CheckImplicitInterfaceArg(evaluate::ActualArgument &,
@@ -43,7 +47,8 @@ void CheckImplicitInterfaceArg(evaluate::ActualArgument &,
bool CheckArguments(const evaluate::characteristics::Procedure &,
evaluate::ActualArguments &, SemanticsContext &, const Scope &,
bool treatingExternalAsImplicit, bool ignoreImplicitVsExplicit,
- const evaluate::SpecificIntrinsic *intrinsic);
+ const evaluate::SpecificIntrinsic *intrinsic,
+ bool isDefinedAssignment = false);
bool CheckPPCIntrinsic(const Symbol &generic, const Symbol &specific,
const evaluate::ActualArguments &actuals,
@@ -58,7 +63,7 @@ parser::Messages CheckExplicitInterface(
const evaluate::characteristics::Procedure &, evaluate::ActualArguments &,
SemanticsContext &, const Scope *, const evaluate::SpecificIntrinsic *,
bool allowActualArgumentConversions, bool extentErrors,
- bool ignoreImplicitVsExplicit);
+ bool ignoreImplicitVsExplicit, bool isDefinedAssignment = false);
// Checks actual arguments for the purpose of resolving a generic interface.
bool CheckInterfaceForGeneric(const evaluate::characteristics::Procedure &,
diff --git a/flang/lib/Semantics/check-deallocate.cpp b/flang/lib/Semantics/check-deallocate.cpp
index c93b940aa69ed..566ff854a88e4 100644
--- a/flang/lib/Semantics/check-deallocate.cpp
+++ b/flang/lib/Semantics/check-deallocate.cpp
@@ -78,7 +78,9 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
// pointer/allocatable
context_
.Say(source,
- "Name in DEALLOCATE statement is not definable"_err_en_US)
+ symbol->attrs().test(Attr::PROTECTED_TARGET)
+ ? "Object in DEALLOCATE statement is not deallocatable"_err_en_US
+ : "Name in DEALLOCATE statement is not definable"_err_en_US)
.Attach(std::move(
whyNot->set_severity(parser::Severity::Because)));
} else if (auto whyNot{WhyNotDefinable(source,
@@ -116,7 +118,9 @@ void DeallocateChecker::Leave(const parser::DeallocateStmt &deallocateStmt) {
*expr)}) {
context_
.Say(source,
- "Name in DEALLOCATE statement is not definable"_err_en_US)
+ symbol->attrs().test(Attr::PROTECTED_TARGET)
+ ? "Object in DEALLOCATE statement is not deallocatable"_err_en_US
+ : "Name in DEALLOCATE statement is not definable"_err_en_US)
.Attach(std::move(
whyNot->set_severity(parser::Severity::Because)));
} else if (auto whyNot{WhyNotDefinable(source,
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 2abefd381850a..7479f047342a3 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -329,6 +329,16 @@ void CheckHelper::Check(const Symbol &symbol) {
CheckValue(symbol, derived);
}
+ if (symbol.attrs().test(Attr::PROTECTED_TARGET) &&
+ (&symbol == &symbol.GetUltimate() ||
+ !symbol.GetUltimate().attrs().test(Attr::PROTECTED_TARGET)) &&
+ (!IsPointer(symbol) ||
+ !symbol.GetUltimate().has<ObjectEntityDetails>())) {
+ // F2028 C781, C8109, and 8.5.16p1
+ messages_.Say(
+ "The PROTECTED_TARGET attribute may apply only to a data pointer"_err_en_US);
+ }
+
if (isDone) {
return; // following checks do not apply
}
@@ -347,6 +357,11 @@ 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) && IsPointer(symbol) &&
+ 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);
}
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 6193b297b62fb..3400e9f5e2978 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -6184,8 +6184,17 @@ void OmpStructureChecker::CheckDefinableObjects(
if (!IsVariableListItem(*symbol)) {
continue;
}
- if (auto msg{WhyNotDefinable(source, context_.FindScope(source),
- DefinabilityFlags{}, *symbol)}) {
+ DefinabilityFlags flags{};
+ if (clause == llvm::omp::Clause::OMPC_lastprivate && IsPointer(*symbol) &&
+ symbol->GetUltimate().attrs().test(Attr::PROTECTED_TARGET)) {
+ if (IsIntentIn(*symbol)) {
+ continue; // CheckIntentInPointer diagnoses this case.
+ }
+ // OpenMP 5.2 5.4.5 updates a pointer list item by pointer assignment.
+ flags.set(DefinabilityFlag::PointerDefinition);
+ }
+ if (auto msg{WhyNotDefinable(
+ source, context_.FindScope(source), flags, *symbol)}) {
context_
.Say(source,
"Variable '%s' on the %s clause is not definable"_err_en_US,
diff --git a/flang/lib/Semantics/definable.cpp b/flang/lib/Semantics/definable.cpp
index d6a654683001f..af0af1d5027a5 100644
--- a/flang/lib/Semantics/definable.cpp
+++ b/flang/lib/Semantics/definable.cpp
@@ -123,7 +123,8 @@ static std::optional<parser::Message> WhyNotDefinableBase(parser::CharBlock at,
return BlameSymbol(at, "'%s' is not a variable"_en_US, original);
} else if (IsProtected(ultimate) && IsUseAssociated(original, scope)) {
return BlameSymbol(at, "'%s' is protected in this scope"_en_US, original);
- } else if (IsIntentIn(ultimate) &&
+ } else if (!flags.test(DefinabilityFlag::ReadOnlyPointerTarget) &&
+ IsIntentIn(ultimate) &&
(!IsPointer(ultimate) || (isWholeSymbol && isPointerDefinition))) {
return BlameSymbol(
at, "'%s' is an INTENT(IN) dummy argument"_en_US, original);
@@ -208,6 +209,17 @@ static std::optional<parser::Message> WhyNotDefinableLast(parser::CharBlock at,
if (!IsAllocatableOrObjectPointer(&ultimate)) {
return BlameSymbol(
at, "'%s' is neither a pointer nor an allocatable"_en_US, original);
+ } else if (ultimate.attrs().test(Attr::PROTECTED_TARGET)) {
+ if (flags.test(DefinabilityFlag::PotentialDeallocation)) { // F2028 C868
+ return BlameSymbol(at,
+ "'%s' has PROTECTED_TARGET and may not be deallocated"_en_US,
+ original);
+ } else if (!flags.test(
+ DefinabilityFlag::SourcedAllocation)) { // F2028 C869
+ return BlameSymbol(at,
+ "'%s' has PROTECTED_TARGET and requires SOURCE= in ALLOCATE"_en_US,
+ original);
+ }
}
} else if (!IsPointer(ultimate)) {
return BlameSymbol(at, "'%s' is not a pointer"_en_US, original);
@@ -253,6 +265,15 @@ 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 (!flags.test(DefinabilityFlag::ReadOnlyPointerTarget)) {
+ if (const Symbol *pointer{FindProtectedTargetPointer(
+ dataRef, flags.test(DefinabilityFlag::PointerDefinition))}) {
+ // F2028 C866 and 8.5.16p2
+ return BlameSymbol(at,
+ "Target of PROTECTED_TARGET pointer '%s' is not definable"_en_US,
+ *pointer);
+ }
+ }
auto whyNotBase{
WhyNotDefinableBase(at, scope, flags, dataRef.GetFirstSymbol(),
evaluate::UnwrapWholeSymbolDataRef(dataRef) != nullptr,
@@ -270,16 +291,7 @@ 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) {
- auto whyNotBase{WhyNotDefinableBase(at, scope, flags, original,
- /*isWholeSymbol=*/true, /*isComponentPointerTarget=*/false)};
- if (!whyNotBase || !whyNotBase->IsFatal()) {
- if (auto whyNotLast{WhyNotDefinableLast(at, scope, flags, original)}) {
- if (whyNotLast->IsFatal() || !whyNotBase) {
- return whyNotLast;
- }
- }
- }
- return whyNotBase;
+ return WhyNotDefinable(at, scope, flags, evaluate::DataRef{original});
}
class DuplicatedSubscriptFinder
@@ -412,6 +424,12 @@ std::optional<parser::Message> WhyNotDefinable(parser::CharBlock at,
}
if (const auto *component{procDesignator->GetComponent()}) {
flags.reset(DefinabilityFlag::PointerDefinition);
+ if (const Symbol *pointer{
+ FindProtectedTargetPointer(component->base())}) {
+ return BlameSymbol(at,
+ "Target of PROTECTED_TARGET pointer '%s' is not definable"_en_US,
+ *pointer);
+ }
return WhyNotDefinableBase(at, scope, flags,
component->base().GetFirstSymbol(), false,
DefinesComponentPointerTarget(component->base(), flags));
@@ -422,9 +440,18 @@ 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 (!evaluate::IsVariable(expr)) {
- return parser::Message{
- at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
+ } else {
+ if (!flags.test(DefinabilityFlag::ReadOnlyPointerTarget)) {
+ if (const Symbol *pointer{FindProtectedTargetPointer(expr)}) {
+ return BlameSymbol(at,
+ "Target of PROTECTED_TARGET pointer '%s' is not definable"_en_US,
+ *pointer);
+ }
+ }
+ if (!evaluate::IsVariable(expr)) {
+ return parser::Message{
+ at, "'%s' is not a variable or pointer"_err_en_US, expr.AsFortran()};
+ }
}
return portabilityWarning;
}
diff --git a/flang/lib/Semantics/definable.h b/flang/lib/Semantics/definable.h
index 816dad3c17fab..303ba3b235fef 100644
--- a/flang/lib/Semantics/definable.h
+++ b/flang/lib/Semantics/definable.h
@@ -31,6 +31,8 @@ ENUM_CLASS(DefinabilityFlag,
PointerDefinition, // a pointer is being defined, not its target
AcceptAllocatable, // treat allocatable as if it were a pointer
SourcedAllocation, // ALLOCATE(a,SOURCE=)
+ ReadOnlyPointerTarget, // target of association with a PROTECTED_TARGET
+ // pointer
PolymorphicOkInPure, // don't check for polymorphic type in pure subprogram
DoNotNoteDefinition, // context does not imply definition
AllowEventLockOrNotifyType, PotentialDeallocation,
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 6448c35b922ff..496dbf4434c43 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -4104,7 +4104,7 @@ static bool IsExternalCalledImplicitly(
std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
parser::CharBlock callSite, const ProcedureDesignator &proc,
- ActualArguments &arguments) {
+ ActualArguments &arguments, bool isDefinedAssignment) {
bool treatExternalAsImplicit{
IsExternalCalledImplicitly(callSite, proc.GetSymbol())};
const Symbol *procSymbol{proc.GetSymbol()};
@@ -4181,19 +4181,25 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
}
if (isStatementFunction) {
// Statement functions have implicit interfaces, so keyword actual
- // arguments are not allowed. They are exempt from the explicit-interface
- // requirements of F2023 15.4.2.2.
+ // arguments and PROTECTED_TARGET actuals (F2028 C873) are not allowed.
+ // They are exempt from the explicit-interface requirements of F2023
+ // 15.4.2.2.
parser::ContextualMessages &messages{
context_.foldingContext().messages()};
for (auto &arg : arguments) {
if (arg) {
semantics::CheckImplicitInterfaceArgKeywords(*arg, messages);
+ ok &= semantics::CheckImplicitInterfaceArgProtectedTarget(
+ *arg, messages);
}
}
}
- ok &= semantics::CheckArguments(*chars, arguments, context_,
- context_.FindScope(callSite), treatExternalAsImplicit,
- /*ignoreImplicitVsExplicit=*/false, specificIntrinsic);
+ if (ok) {
+ ok = semantics::CheckArguments(*chars, arguments, context_,
+ context_.FindScope(callSite), treatExternalAsImplicit,
+ /*ignoreImplicitVsExplicit=*/false, specificIntrinsic,
+ isDefinedAssignment);
+ }
}
if (ok && !treatExternalAsImplicit && procSymbol &&
!(chars && chars->HasExplicitInterface())) {
@@ -4205,7 +4211,7 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
semantics::CheckArguments(*globalChars, arguments, context_,
context_.FindScope(callSite), /*treatExternalAsImplicit=*/true,
/*ignoreImplicitVsExplicit=*/false,
- nullptr /*not specific intrinsic*/);
+ nullptr /*not specific intrinsic*/, isDefinedAssignment);
}
}
}
@@ -5794,7 +5800,10 @@ std::optional<ProcedureRef> ArgumentAnalyzer::TryDefinedAssignment() {
"Defined assignment in WHERE must be elemental, but '%s' is not"_err_en_US,
DEREF(procRef->proc().GetSymbol()).name());
}
- context_.CheckCall(source_, procRef->proc(), procRef->arguments());
+ // F2028 15.4.3.4.3 applies argument constraints to a parenthesized
+ // RHS, even when lowering needs the unparenthesized variable.
+ context_.CheckCall(source_, procRef->proc(), procRef->arguments(),
+ /*isDefinedAssignment=*/true);
return std::move(*procRef);
}
if (isDefined == Tristate::Yes) {
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 7425f831b51b4..84aa524a003f0 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,19 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
if (lhs_ && IsProcedure(*lhs_)) {
return true;
}
+ if (lhs_ && !isProtectedTarget_) {
+ if (const Symbol *pointer{FindProtectedTargetPointer(
+ rhs, false, /*followAssociations=*/false)}) {
+ if (pointerComponentLHS_) { // F2028 C871
+ Say("Pointer component '%s' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer '%s'"_err_en_US,
+ pointerComponentLHS_->name(), pointer->name());
+ } else { // F2028 C870
+ Say("Pointer '%s' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer '%s'"_err_en_US,
+ lhs_->name(), pointer->name());
+ }
+ return false;
+ }
+ }
if (const auto *pureProc{FindPureProcedureContaining(scope_)}) {
if (pointerComponentLHS_) { // F'2023 C15104(4) is a hard error
if (const Symbol * object{FindExternallyVisibleObject(rhs, *pureProc)}) {
@@ -244,8 +267,12 @@ bool PointerAssignmentChecker::Check(const SomeExpr &rhs) {
}
}
// Warn about undefinable data targets
- if (auto because{
- WhyNotDefinable(foldingContext_.messages().at(), scope_, {}, rhs)}) {
+ DefinabilityFlags flags;
+ if (isProtectedTarget_) {
+ flags.set(DefinabilityFlag::ReadOnlyPointerTarget);
+ }
+ if (auto because{WhyNotDefinable(
+ foldingContext_.messages().at(), scope_, flags, rhs)}) {
if (auto *msg{Warn(common::UsageWarning::PointerToUndefinable,
"Pointer target is not a definable variable"_warn_en_US)}) {
msg->Attach(std::move(because->set_severity(parser::Severity::Because)));
@@ -619,6 +646,7 @@ 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.isProtectedTarget)
.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 67690d6f47d06..75bc564cfc186 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)
@@ -1089,6 +1090,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 &) {
@@ -6718,6 +6720,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);
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 48ff27f214649..90c1fb9eb54e5 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"
@@ -440,6 +441,93 @@ const evaluate::Assignment *GetAssignment(
: nullptr;
}
+namespace {
+struct ProtectedTargetSymbolVector
+ : public evaluate::Traverse<ProtectedTargetSymbolVector, SymbolVector> {
+ using Result = SymbolVector;
+ using Base = evaluate::Traverse<ProtectedTargetSymbolVector, Result>;
+ using Base::operator();
+ explicit ProtectedTargetSymbolVector(bool followAssociations)
+ : Base{*this}, followAssociations_{followAssociations} {}
+ Result Default() { return {}; }
+ Result Combine(Result &&a, Result &&b) {
+ a.insert(a.end(), b.begin(), b.end());
+ return std::move(a);
+ }
+ Result operator()(const Symbol &symbol) const {
+ const auto *assoc{symbol.GetUltimate().detailsIf<AssocEntityDetails>()};
+ // RANK DEFAULT has the selector's attributes (F2028 11.1.12.3p2).
+ if (followAssociations_ || (assoc && assoc->IsAssumedRank())) {
+ if (const auto *selector{evaluate::GetVariableSelector(symbol)}) {
+ return (*this)(*selector);
+ }
+ }
+ return {symbol};
+ }
+ Result operator()(const evaluate::Component &component) const {
+ Result result{(*this)(component.base())};
+ result.emplace_back(component.GetLastSymbol());
+ return result;
+ }
+ Result operator()(const evaluate::ArrayRef &array) const {
+ return (*this)(array.base());
+ }
+ Result operator()(const evaluate::Substring &substring) const {
+ if (const auto *dataRef{
+ std::get_if<evaluate::DataRef>(&substring.parent())}) {
+ return (*this)(*dataRef);
+ }
+ return {};
+ }
+ Result operator()(const evaluate::CoarrayRef &coarray) const {
+ return (*this)(coarray.base());
+ }
+
+private:
+ bool followAssociations_;
+};
+} // namespace
+
+const Symbol *FindProtectedTargetPointer(const evaluate::DataRef &dataRef,
+ bool isPointerDefinition, bool followAssociations) {
+ auto symbols{ProtectedTargetSymbolVector{followAssociations}(dataRef)};
+ if (isPointerDefinition && !symbols.empty()) {
+ symbols.pop_back();
+ }
+ for (auto it{symbols.rbegin()}; it != symbols.rend(); ++it) {
+ const Symbol &symbol{(**it).GetUltimate()};
+ if (IsPointer(symbol)) {
+ return symbol.attrs().test(Attr::PROTECTED_TARGET) ? &**it : nullptr;
+ }
+ if (const auto *assoc{symbol.detailsIf<AssocEntityDetails>()};
+ followAssociations && assoc && assoc->expr()) {
+ if (const Symbol *pointer{FindProtectedTargetPointer(*assoc->expr())}) {
+ return pointer;
+ }
+ }
+ }
+ return nullptr;
+}
+
+const Symbol *FindProtectedTargetPointer(
+ const SomeExpr &expr, bool isPointerDefinition, bool followAssociations) {
+ if (auto dataRef{evaluate::ExtractDataRef(expr, true, true)}) {
+ return FindProtectedTargetPointer(
+ *dataRef, isPointerDefinition, followAssociations);
+ }
+ if (!isPointerDefinition) {
+ if (const auto *call{evaluate::UnwrapProcedureRef(expr)}) {
+ if (const Symbol *procedure{call->proc().GetSymbol()}) {
+ if (const Symbol *result{FindFunctionResult(*procedure)};
+ result && result->attrs().test(Attr::PROTECTED_TARGET)) {
+ return result;
+ }
+ }
+ }
+ }
+ return nullptr;
+}
+
const Symbol *FindInterface(const Symbol &symbol) {
return common::visit(
common::visitors{
diff --git a/flang/test/Parser/protected-target.f90 b/flang/test/Parser/protected-target.f90
new file mode 100644
index 0000000000000..c869bf15bd8a2
--- /dev/null
+++ b/flang/test/Parser/protected-target.f90
@@ -0,0 +1,29 @@
+! RUN: %flang_fc1 -fdebug-dump-parse-tree %s | FileCheck %s --check-prefix=TREE
+! RUN: %flang_fc1 -fdebug-unparse-no-sema %s | FileCheck %s --check-prefix=UNPARSE
+
+module protected_target_syntax
+ integer, pointer, protected_target :: p
+ type :: t
+ integer, protected_target, pointer :: component
+ end type
+ integer, pointer :: q, r
+ protected_target :: q
+ protected_target r
+end module
+
+subroutine keyword_as_name()
+ integer :: protected_target
+ protected_target = 1
+end subroutine
+
+! TREE: AttrSpec -> ProtectedTarget
+! TREE: ComponentAttrSpec -> ProtectedTarget
+! TREE: OtherSpecificationStmt -> ProtectedTargetStmt
+! TREE: OtherSpecificationStmt -> ProtectedTargetStmt
+
+! UNPARSE: INTEGER, POINTER, PROTECTED_TARGET :: p
+! UNPARSE: INTEGER, PROTECTED_TARGET, POINTER :: component
+! UNPARSE: PROTECTED_TARGET :: q
+! UNPARSE: PROTECTED_TARGET :: r
+! UNPARSE: INTEGER protected_target
+! UNPARSE: protected_target = 1
diff --git a/flang/test/Semantics/CUDA/protected-target.cuf b/flang/test/Semantics/CUDA/protected-target.cuf
new file mode 100644
index 0000000000000..f78834e211583
--- /dev/null
+++ b/flang/test/Semantics/CUDA/protected-target.cuf
@@ -0,0 +1,24 @@
+! RUN: %python %S/../test_errors.py %s %flang_fc1
+
+module protected_target_device_assignment
+ type :: item
+ real :: values(2)
+ end type
+ interface assignment(=)
+ module procedure copy_device
+ end interface
+contains
+ subroutine copy_device(lhs, rhs)
+ type(item), intent(out) :: lhs
+ real, device, intent(in) :: rhs(2)
+ lhs%values = rhs
+ end subroutine
+ subroutine assignments(readonly, writable, lhs)
+ real, device, pointer, protected_target :: readonly(:)
+ real, device, pointer :: writable(:)
+ type(item) :: lhs
+ ! A PROTECTED_TARGET DEVICE pointer RHS is valid with an INTENT(IN) dummy.
+ lhs = readonly
+ lhs = writable
+ end subroutine
+end module
diff --git a/flang/test/Semantics/OpenMP/protected-target.f90 b/flang/test/Semantics/OpenMP/protected-target.f90
new file mode 100644
index 0000000000000..da623094a285c
--- /dev/null
+++ b/flang/test/Semantics/OpenMP/protected-target.f90
@@ -0,0 +1,116 @@
+! RUN: %python %S/../test_errors.py %s %flang_fc1 -fopenmp -fopenmp-version=52
+
+module protected_target_lastprivate
+ integer, pointer, protected_target :: module_pointer
+contains
+ subroutine host_association(target)
+ integer, target :: target
+ !$omp parallel sections lastprivate(module_pointer)
+ !$omp section
+ module_pointer => target
+ !$omp end parallel sections
+ end subroutine
+end module
+
+subroutine pointer_association(p, ordinary, target)
+ integer, pointer, protected_target :: p
+ integer, pointer :: ordinary
+ integer, target :: target
+ integer :: i
+ ! LASTPRIVATE updates pointer association, not the protected target.
+ !$omp parallel do lastprivate(p, ordinary)
+ do i = 1, 2
+ p => target
+ ordinary => target
+ end do
+ !$omp end parallel do
+end subroutine
+
+subroutine use_association(target)
+ use protected_target_lastprivate, only: renamed => module_pointer
+ integer, target :: target
+ !$omp parallel sections lastprivate(renamed)
+ !$omp section
+ renamed => target
+ !$omp end parallel sections
+end subroutine
+
+subroutine region_association(p, q, ordinary, target, readonly_target)
+ integer, pointer, protected_target :: p, q
+ integer, pointer :: ordinary
+ integer, target :: target
+ integer, target, intent(in) :: readonly_target
+ integer :: i
+ !$omp parallel
+ p => q
+ p => readonly_target
+ ordinary => target
+ !ERROR: Pointer 'ordinary' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'q'
+ ordinary => q
+ !$omp end parallel
+
+ !$omp parallel private(p, ordinary) firstprivate(q)
+ p => q
+ p => ordinary
+ ordinary => target
+ !ERROR: Pointer 'ordinary' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'q'
+ ordinary => q
+ !$omp end parallel
+
+ !$omp task firstprivate(p, q, ordinary)
+ p => q
+ ordinary => target
+ !ERROR: Pointer 'ordinary' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'q'
+ ordinary => q
+ !$omp end task
+
+ !$omp parallel do lastprivate(p, ordinary) firstprivate(q)
+ do i = 1, 2
+ p => q
+ ordinary => target
+ !ERROR: Pointer 'ordinary' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'q'
+ ordinary => q
+ end do
+ !$omp end parallel do
+end subroutine
+
+subroutine use_region_association(q, ordinary, target)
+ use protected_target_lastprivate, only: renamed => module_pointer
+ integer, pointer, protected_target :: q
+ integer, pointer :: ordinary
+ integer, target :: target
+ !$omp parallel
+ renamed => q
+ q => renamed
+ renamed => ordinary
+ ordinary => target
+ !ERROR: Pointer 'ordinary' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'q'
+ ordinary => q
+ !ERROR: Pointer 'ordinary' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'renamed'
+ ordinary => renamed
+ !$omp end parallel
+end subroutine
+
+subroutine intent_in_pointers(p, ordinary)
+ integer, pointer, protected_target, intent(in) :: p
+ integer, pointer, intent(in) :: ordinary
+ integer :: i
+ !ERROR: Pointer 'p' with the INTENT(IN) attribute may not appear in a LASTPRIVATE clause
+ !ERROR: Pointer 'ordinary' with the INTENT(IN) attribute may not appear in a LASTPRIVATE clause
+ !$omp parallel do lastprivate(p, ordinary)
+ do i = 1, 2
+ end do
+ !$omp end parallel do
+end subroutine
+
+subroutine target_definition(p)
+ integer, pointer, protected_target :: p
+ integer :: i
+ ! REDUCTION still defines the target (F2028 C866).
+ !ERROR: Variable 'p' on the REDUCTION clause is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ !$omp parallel do reduction(+:p)
+ do i = 1, 2
+ end do
+ !$omp end parallel do
+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 0000000000000..944e845430640
--- /dev/null
+++ b/flang/test/Semantics/modfile-protected-target.f90
@@ -0,0 +1,79 @@
+! RUN: split-file %s %t
+! RUN: %python %S/test_modfile.py %t/m.f90 %flang_fc1
+! RUN: %flang_fc1 -fsyntax-only -J%t %t/m.f90
+! RUN: %python %S/test_errors.py %t/use.f90 %flang_fc1 -I%t -pedantic
+
+!--- m.f90
+module protected_target_mod
+ integer, pointer, protected_target :: p
+ integer, pointer :: q
+ protected_target q
+ type :: t
+ integer, pointer, protected_target :: c
+ end type
+contains
+ subroutine accept(a)
+ integer, pointer, protected_target, intent(in) :: a
+ end subroutine
+ function get() result(r)
+ integer, pointer, protected_target :: r
+ r => p
+ end function
+end module
+
+!Expect: protected_target_mod.mod
+!module protected_target_mod
+!integer(4),pointer,protected_target::p
+!integer(4),pointer,protected_target::q
+!type::t
+!integer(4),pointer,protected_target::c
+!end type
+!contains
+!subroutine accept(a)
+!integer(4),intent(in),pointer,protected_target::a
+!end
+!function get() result(r)
+!integer(4),pointer,protected_target::r
+!end
+!end
+
+!--- use.f90
+subroutine use_protected_target()
+ use protected_target_mod, only: local => p, q, t, get, accept
+ interface
+ subroutine pointer_in(p)
+ integer, pointer, intent(in) :: p
+ end subroutine
+ subroutine value_inout(p)
+ integer, intent(inout) :: p
+ end subroutine
+ end interface
+ external :: implicit_interface
+ integer, pointer :: writable
+ integer, pointer, protected_target :: readonly
+ type(t) :: object
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'local' is not definable
+ local = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'q' is not definable
+ q = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'c' is not definable
+ object%c = 1
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'local'
+ writable => local
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'r'
+ writable => get()
+ readonly => local
+ readonly => get()
+ call accept(local)
+ call accept(writable)
+ call accept(get())
+ !ERROR: POINTER dummy argument 'p=' must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer 'local' or its subobject
+ call pointer_in(local)
+ !ERROR: Nonpointer dummy argument 'p=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'local' or its subobject
+ call value_inout(local)
+ !ERROR: PROTECTED_TARGET pointer 'local' or its subobject may not be passed to a procedure with an implicit interface
+ call implicit_interface(local)
+end subroutine
diff --git a/flang/test/Semantics/protected-target01.f90 b/flang/test/Semantics/protected-target01.f90
new file mode 100644
index 0000000000000..3ff4ee89792b9
--- /dev/null
+++ b/flang/test/Semantics/protected-target01.f90
@@ -0,0 +1,89 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+
+module protected_target_declarations
+ ! F2028 8.5.16p1: the attribute imposes limitations on the usage of
+ ! a data pointer.
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ integer, protected_target :: not_pointer
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ integer, pointer, external, protected_target :: procedure_pointer
+
+ type :: t
+ ! F2028 C781: POINTER must be in the same component attribute list.
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ integer, protected_target :: not_pointer_component
+ integer, protected_target, pointer :: p
+ end type
+contains
+ subroutine statement()
+ ! F2028 C8109
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ integer :: not_pointer
+ protected_target :: not_pointer
+ end subroutine
+
+ subroutine procedure_statement()
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ procedure(), pointer :: p
+ protected_target p
+ end subroutine
+
+ ! F2028 R863: a subroutine name is not a variable-name.
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ subroutine subprogram_name()
+ protected_target :: subprogram_name
+ end subroutine
+
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ function separate_result() result(r)
+ integer :: r
+ protected_target :: separate_result
+ r = 1
+ end function
+
+ subroutine common_pointer()
+ ! F2028 C867
+ !ERROR: A PROTECTED_TARGET pointer may not be in a common block
+ integer, pointer, protected_target :: p
+ common /block/ p
+ end subroutine
+
+ subroutine common_statement_pointer()
+ ! F2028 C867 also applies to the statement form.
+ !ERROR: A PROTECTED_TARGET pointer may not be in a common block
+ integer, pointer :: p
+ protected_target :: p
+ common /statement_block/ p
+ end subroutine
+
+ subroutine common_nonpointer()
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ integer, protected_target :: p
+ common /nonpointer_block/ p
+ end subroutine
+
+ subroutine repeated()
+ !WARNING: Attribute 'PROTECTED_TARGET' cannot be used more than once [-Wredundant-attribute]
+ integer, pointer, protected_target, protected_target :: p
+ end subroutine
+end module
+
+module protected_target_declaration_association
+ ! Diagnose the declaring entity, not each associated reference.
+ !ERROR: The PROTECTED_TARGET attribute may apply only to a data pointer
+ integer, protected_target :: invalid
+ integer, pointer, protected_target :: valid
+contains
+ subroutine host_reference()
+ print *, invalid, valid
+ end subroutine
+end module
+
+subroutine renamed_reference()
+ use protected_target_declaration_association, only: local => invalid, valid
+ print *, local, valid
+contains
+ subroutine host_reference()
+ print *, local, valid
+ end subroutine
+end subroutine
diff --git a/flang/test/Semantics/protected-target02.f90 b/flang/test/Semantics/protected-target02.f90
new file mode 100644
index 0000000000000..a9ab6c20f6792
--- /dev/null
+++ b/flang/test/Semantics/protected-target02.f90
@@ -0,0 +1,299 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+
+module protected_target_checks
+ type :: t
+ integer :: value
+ integer, allocatable :: allocated
+ integer, pointer :: writable
+ integer, pointer, protected_target :: readonly
+ end type
+ type :: ordinary
+ integer, pointer :: p
+ end type
+ type :: guarded
+ integer, pointer, protected_target :: p
+ end type
+contains
+ subroutine definitions(p, n, text, z, object)
+ integer, pointer, protected_target :: p(:), n
+ character(20), pointer, protected_target :: text
+ complex, pointer, protected_target :: z
+ type(t), pointer, protected_target :: object
+ integer, target :: target
+ integer :: i
+ ! F2028 C866 and 8.5.16p2
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ p = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ p(1) = 1
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'text' is not definable
+ text(1:2) = 'hi'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'z' is not definable
+ z%re = 1.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ object%value = 1
+ !ERROR: 'n' may not be used as a DO variable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'n' is not definable
+ do n = 1, 2
+ end do
+ !ERROR: Input variable 'n' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'n' is not definable
+ read *, n
+ !ERROR: Internal file variable 'text' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'text' is not definable
+ write(text, *) 1
+ !ERROR: IOSTAT variable 'n' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'n' is not definable
+ read(*, *, iostat=n) i
+ associate (a => p(1))
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ a = 1
+ end associate
+ associate (a => object%value)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ a = 1
+ end associate
+
+ ! Pointer targets are not subobjects of their containing object.
+ object%writable = 1
+ ! Flang treats component association changes as changing the protected target.
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ object%writable => target
+ !ERROR: 'writable' may not appear in NULLIFY
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ nullify(object%writable)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ allocate(object%writable, source=1)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ allocate(object%allocated, source=1)
+ !ERROR: Name in DEALLOCATE statement is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ deallocate(object%allocated)
+ print *, p, n, text, z, object%value
+ end subroutine
+
+ subroutine associate_names(p, object)
+ integer, pointer, protected_target :: p
+ type(t), pointer, protected_target :: object
+ integer, pointer :: writable
+ integer, pointer, protected_target :: readonly
+ type(ordinary) :: ordinary_value
+ type(guarded) :: guarded_value
+ external :: implicit_interface
+ ! An associate name does not acquire PROTECTED_TARGET (F2028 11.1.3.3).
+ associate (a => p)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ writable => a
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ call pointer_in(a)
+ call implicit_interface(a)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ ordinary_value = ordinary(a)
+ readonly => a
+ guarded_value = guarded(a)
+ call value_in(a)
+ call value_default(a)
+ ! 11.1.3.3p5 still prohibits variable definition contexts.
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'p=' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ call value_inout(a)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ a = 1
+ end associate
+ associate (a => object)
+ ! A pointer component written in the designator retains its attribute.
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'readonly'
+ writable => a%readonly
+ !ERROR: Pointer component 'p' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'readonly'
+ ordinary_value = ordinary(a%readonly)
+ !ERROR: POINTER dummy argument 'p=' must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer 'readonly' or its subobject
+ call pointer_in(a%readonly)
+ !ERROR: PROTECTED_TARGET pointer 'readonly' or its subobject may not be passed to a procedure with an implicit interface
+ call implicit_interface(a%readonly)
+ !ERROR: Nonpointer dummy argument 'p=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'readonly' or its subobject
+ call value_default(a%readonly)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ a%value = 1
+ writable => a%writable
+ call pointer_in(a%writable)
+ call implicit_interface(a%writable)
+ end associate
+ end subroutine
+
+ subroutine associate_elements(p)
+ integer, pointer, protected_target :: p(:)
+ integer, pointer :: writable
+ external :: implicit_interface
+ associate (a => p)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ writable => a(1)
+ call implicit_interface(a(1))
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'p=' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ call value_inout(a(1))
+ end associate
+ end subroutine
+
+ subroutine allocation(p, object)
+ integer, pointer, protected_target :: p
+ type(t) :: object
+ ! F2028 C869
+ !ERROR: Object in ALLOCATE statement may not be allocated
+ !BECAUSE: 'p' has PROTECTED_TARGET and requires SOURCE= in ALLOCATE
+ allocate(p)
+ !ERROR: Object in ALLOCATE statement may not be allocated
+ !BECAUSE: 'p' has PROTECTED_TARGET and requires SOURCE= in ALLOCATE
+ allocate(p, mold=1)
+ !ERROR: Object in ALLOCATE statement may not be allocated
+ !BECAUSE: 'readonly' has PROTECTED_TARGET and requires SOURCE= in ALLOCATE
+ allocate(object%readonly)
+ allocate(p, source=1)
+ allocate(object%readonly, source=1)
+ ! F2028 C868
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'p' has PROTECTED_TARGET and may not be deallocated
+ deallocate(p)
+ !ERROR: Object in DEALLOCATE statement is not deallocatable
+ !BECAUSE: 'readonly' has PROTECTED_TARGET and may not be deallocated
+ deallocate(object%readonly)
+ nullify(p, object%readonly)
+ end subroutine
+
+ subroutine association(p, array, object)
+ integer, pointer, protected_target :: p, array(:)
+ type(t), pointer, protected_target :: object
+ integer, pointer :: writable
+ integer, pointer, protected_target :: readonly
+ type(ordinary) :: ordinary_value
+ type(guarded) :: guarded_value
+ ! F2028 C870
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'p'
+ writable => p
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'array'
+ writable => array(1)
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'object'
+ writable => object%value
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'readonly'
+ writable => object%readonly
+ writable => object%writable
+ readonly => p
+ readonly => writable
+ readonly => object%value
+ nullify(readonly)
+ ! F2028 C871
+ !ERROR: Pointer component 'p' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'p'
+ ordinary_value = ordinary(p)
+ !ERROR: Pointer component 'p' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'object'
+ ordinary_value = ordinary(object%value)
+ guarded_value = guarded(p)
+ guarded_value = guarded(object%value)
+ ordinary_value = ordinary(object%writable)
+ end subroutine
+
+ subroutine arguments(p, object)
+ integer, pointer, protected_target :: p
+ type(t), pointer, protected_target :: object
+ external :: implicit_interface
+ ! F2028 C872
+ !ERROR: POINTER dummy argument 'p=' must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer 'p' or its subobject
+ call pointer_in(p)
+ !ERROR: POINTER dummy argument 'p=' must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer 'p' or its subobject
+ call pointer_out(p)
+ !ERROR: POINTER dummy argument 'p=' must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer 'object' or its subobject
+ call pointer_in(object%value)
+ call pointer_in(object%writable)
+ ! Flang checks the container when the component's association may change.
+ !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'p=' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'object' is not definable
+ call pointer_inout(object%writable)
+ call protected_in(p)
+ call protected_out(p)
+ call protected_default(p)
+ call protected_in(object%value)
+ ! F2028 C873
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be passed to a procedure with an implicit interface
+ call implicit_interface(p)
+ !ERROR: PROTECTED_TARGET pointer 'object' or its subobject may not be passed to a procedure with an implicit interface
+ call implicit_interface(object%value)
+ call implicit_interface(p + 1)
+ call implicit_interface((p))
+ ! F2028 C874
+ !ERROR: Nonpointer dummy argument 'p=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'p' or its subobject
+ call value_out(p)
+ !ERROR: Nonpointer dummy argument 'p=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'p' or its subobject
+ call value_inout(p)
+ !ERROR: Nonpointer dummy argument 'p=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'p' or its subobject
+ call value_default(p)
+ !ERROR: Nonpointer dummy argument 'p=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'object' or its subobject
+ call value_default(object%value)
+ call value_in(p)
+ call value_in(object%value)
+ call value_default(p + 1)
+ call value_default((p))
+ end subroutine
+
+ subroutine status(p)
+ integer, pointer, protected_target, intent(in) :: p
+ integer, target :: target
+ ! PROTECTED_TARGET does not relax INTENT(IN) on pointer association.
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ p => target
+ !ERROR: 'p' may not appear in NULLIFY
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ nullify(p)
+ !ERROR: Name in ALLOCATE statement is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ allocate(p, source=1)
+ !ERROR: Actual argument associated with INTENT(OUT) dummy argument 'p=' is not definable
+ !BECAUSE: 'p' is an INTENT(IN) dummy argument
+ call protected_out(p)
+ end subroutine
+
+ subroutine pointer_in(p)
+ integer, pointer, intent(in) :: p
+ end subroutine
+ subroutine pointer_out(p)
+ integer, pointer, intent(out) :: p
+ end subroutine
+ subroutine pointer_inout(p)
+ integer, pointer, intent(inout) :: p
+ end subroutine
+ subroutine protected_in(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end subroutine
+ subroutine protected_out(p)
+ integer, pointer, protected_target, intent(out) :: p
+ end subroutine
+ subroutine protected_default(p)
+ integer, pointer, protected_target :: p
+ end subroutine
+ subroutine value_in(p)
+ integer, intent(in) :: p
+ end subroutine
+ subroutine value_out(p)
+ integer, intent(out) :: p
+ end subroutine
+ subroutine value_inout(p)
+ integer, intent(inout) :: p
+ end subroutine
+ subroutine value_default(p)
+ integer :: p
+ 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..44e2529cb6ed0
--- /dev/null
+++ b/flang/test/Semantics/protected-target03.f90
@@ -0,0 +1,140 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+
+module protected_target_uses
+ integer, target, protected :: protected_value
+ integer, pointer, protected, protected_target :: protected_pointer
+ type :: readonly_holder
+ integer, pointer, protected_target :: p
+ end type
+ type :: ordinary_holder
+ integer, pointer :: p
+ end type
+ type :: result_provider
+ contains
+ procedure, nopass :: get => pointer_result
+ generic :: generic_get => get
+ end type
+ interface generic_result
+ module procedure pointer_result
+ end interface
+ abstract interface
+ subroutine ordinary_interface(p)
+ integer, pointer, intent(in) :: p
+ end subroutine
+ subroutine protected_interface(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end subroutine
+ end interface
+contains
+ subroutine associate_in_module()
+ protected_pointer => protected_value
+ end subroutine
+ subroutine positive(target, ordinary_pointer)
+ integer, target, intent(in) :: target
+ integer, pointer :: ordinary_pointer
+ integer, pointer, protected_target :: p, q
+ integer, pointer :: array(:)
+ integer, pointer, protected_target :: protected_array(:)
+ type(readonly_holder) :: readonly_value
+ type(ordinary_holder) :: ordinary_value
+ integer :: value
+ logical :: is_associated
+ protected_target :: ordinary_statement_pointer
+ integer, pointer :: ordinary_statement_pointer
+ p => target
+ readonly_value = readonly_holder(target)
+ call readonly_dummy(target)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'target' is an INTENT(IN) dummy argument
+ ordinary_value = ordinary_holder(target)
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'target' is an INTENT(IN) dummy argument
+ call ordinary_dummy(target)
+ p => ordinary_pointer
+ q => p
+ allocate(array(2), source=[1, 2])
+ protected_array => array
+ protected_array(1:) => array
+ protected_array(1:2) => array
+ nullify(p, q, protected_array, ordinary_statement_pointer)
+ allocate(p, source=1)
+ q => p
+ allocate(protected_array(2), source=[1, 2])
+ value = p + q
+ is_associated = associated(p)
+ value = size(protected_array) + sum(protected_array)
+ p => null(mold=q)
+ print *, value, is_associated
+ deallocate(array)
+ end subroutine
+
+ subroutine readonly_dummy(p)
+ integer, pointer, protected_target, intent(in) :: p
+ end subroutine
+
+ subroutine ordinary_dummy(p)
+ integer, pointer, intent(in) :: p
+ end subroutine
+
+ subroutine characteristics(ordinary)
+ procedure(ordinary_interface) :: ordinary
+ procedure(protected_interface), pointer :: p
+ ! PROTECTED_TARGET is not a dummy characteristic in F2028 15.3.2.2.
+ p => ordinary
+ end subroutine
+
+ function pointer_result() result(p)
+ integer, pointer, protected_target :: p
+ nullify(p)
+ end function
+
+ function implicit_pointer_result()
+ integer, pointer :: implicit_pointer_result
+ protected_target :: implicit_pointer_result
+ nullify(implicit_pointer_result)
+ end function
+
+ subroutine host_association(p)
+ integer, pointer, protected_target :: p
+ contains
+ subroutine read_target()
+ print *, p
+ end subroutine
+ end subroutine
+
+ subroutine function_results()
+ integer, pointer :: writable
+ integer, pointer, protected_target :: readonly
+ type(result_provider) :: provider
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'p'
+ writable => pointer_result()
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'p'
+ writable => generic_result()
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'p'
+ writable => provider%get()
+ !ERROR: Pointer 'writable' must have PROTECTED_TARGET to associate with target of PROTECTED_TARGET pointer 'p'
+ writable => provider%generic_get()
+ readonly => pointer_result()
+ readonly => provider%get()
+ associate (a => pointer_result())
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ a = 1
+ end associate
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'p' is not definable
+ pointer_result() = 1
+ end subroutine
+end module
+
+subroutine preserve_protected()
+ use protected_target_uses
+ integer, pointer, protected_target :: p
+ ! Flang warns for a use-associated PROTECTED nonpointer target (F2028 C864).
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: 'protected_value' is protected in this scope
+ p => protected_value
+ !ERROR: The left-hand side of a pointer assignment is not definable
+ !BECAUSE: 'protected_pointer' is protected in this scope
+ protected_pointer => p
+end subroutine
diff --git a/flang/test/Semantics/protected-target04.f90 b/flang/test/Semantics/protected-target04.f90
new file mode 100644
index 0000000000000..59336adffdccc
--- /dev/null
+++ b/flang/test/Semantics/protected-target04.f90
@@ -0,0 +1,210 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+
+module protected_target_calls
+ type :: item
+ integer :: value
+ contains
+ procedure :: set
+ procedure :: get
+ end type
+ type :: value_item
+ integer :: value
+ contains
+ procedure :: assign_value_object
+ generic :: assignment(=) => assign_value_object
+ end type
+ type :: value_parent
+ type(value_item) :: child
+ end type
+ interface update
+ module procedure update_whole, read_each
+ end interface
+ interface pointer_or_value
+ module procedure by_pointer, each_value
+ end interface
+ interface assignment(=)
+ module procedure assign_item, assign_value
+ end interface
+contains
+ subroutine generic_calls(readonly, writable)
+ integer, pointer, protected_target :: readonly(:)
+ integer, pointer :: writable(:)
+ ! F2028 C874 does not change which specific is selected.
+ !ERROR: Nonpointer dummy argument 'whole=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'readonly' or its subobject
+ call update(readonly)
+ call update(writable)
+ ! F2028 C872 does not change which specific is selected.
+ !ERROR: POINTER dummy argument 'whole=' must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer 'readonly' or its subobject
+ call pointer_or_value(readonly)
+ call pointer_or_value(writable)
+ end subroutine
+
+ subroutine update_whole(whole)
+ integer, intent(inout) :: whole(:)
+ whole = 0
+ end subroutine
+ elemental subroutine read_each(element)
+ integer, intent(in) :: element
+ end subroutine
+ subroutine by_pointer(whole)
+ integer, pointer, intent(in) :: whole(:)
+ end subroutine
+ elemental subroutine each_value(element)
+ integer, intent(in) :: element
+ end subroutine
+
+ subroutine assignments(readonly, writable)
+ type(item), pointer, protected_target :: readonly
+ type(item), pointer :: writable
+ ! Defined assignment resolves even though the LHS violates F2028 C866/C874.
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'readonly' is not definable
+ !ERROR: Nonpointer dummy argument 'lhs=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'readonly' or its subobject
+ readonly = 1
+ writable = 1
+ end subroutine
+ subroutine assign_item(lhs, rhs)
+ type(item), intent(out) :: lhs
+ integer, intent(in) :: rhs
+ lhs%value = rhs
+ end subroutine
+
+ subroutine assignment_rhs(readonly, writable, object, values, mask)
+ integer, pointer, protected_target :: readonly(:)
+ integer, pointer :: writable(:)
+ type(value_parent), pointer, protected_target :: object
+ type(value_item) :: value, values(:)
+ type(item) :: in_value
+ logical :: mask(:)
+ integer :: i
+ ! F2028 15.4.3.4.3 parenthesizes the RHS even for a VALUE dummy.
+ value = readonly(1)
+ value = writable(1)
+ in_value = readonly(1)
+ values = readonly
+ where (mask) values = readonly
+ forall (i = 1:size(readonly)) values(i) = readonly(i)
+ value = object%child
+ call assign_value(value, (readonly(1)))
+ call assign_item(in_value, readonly(1))
+ call value%assign_value_object((object%child))
+ ! An explicit call with an unparenthesized actual still follows F2028 C874.
+ !ERROR: Nonpointer dummy argument 'rhs=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'readonly' or its subobject
+ call assign_value(value, readonly(1))
+ !ERROR: Nonpointer dummy argument 'rhs=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'object' or its subobject
+ call value%assign_value_object(object%child)
+ end subroutine
+ elemental subroutine assign_value(lhs, rhs)
+ type(value_item), intent(out) :: lhs
+ integer, value :: rhs
+ lhs%value = rhs
+ end subroutine
+ subroutine assign_value_object(lhs, rhs)
+ class(value_item), intent(out) :: lhs
+ type(value_item), value :: rhs
+ lhs%value = rhs%value
+ end subroutine
+
+ subroutine bound_calls(readonly, writable)
+ type(item), pointer, protected_target :: readonly
+ type(item), pointer :: writable
+ integer :: value
+ ! F2028 C874 also applies to the passed-object actual argument.
+ !ERROR: Nonpointer dummy argument 'this=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'readonly' or its subobject
+ call readonly%set(1)
+ value = readonly%get()
+ call writable%set(value)
+ end subroutine
+ subroutine set(this, value)
+ class(item), intent(inout) :: this
+ integer, intent(in) :: value
+ this%value = value
+ end subroutine
+ integer function get(this)
+ class(item), intent(in) :: this
+ get = this%value
+ end function
+
+ subroutine statement_function(p)
+ integer, pointer, protected_target :: p
+ integer :: sf, i, value
+ sf(i) = i + 1
+ ! F2028 C873: a statement function has an implicit interface.
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be passed to a procedure with an implicit interface
+ value = sf(p)
+ value = sf(p + 1)
+ value = sf((p))
+ end subroutine
+
+ subroutine implicit_call_location(p, ordinary)
+ integer, pointer, protected_target :: p
+ integer, pointer :: ordinary
+ external :: implicit_subroutine
+ call implicit_subroutine( &
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be passed to a procedure with an implicit interface
+ p)
+ call implicit_subroutine(ordinary)
+ end subroutine
+
+ subroutine implicit_function(p, dummy_function)
+ integer, pointer, protected_target :: p
+ integer, external :: f
+ procedure(integer) :: dummy_function
+ procedure(integer), pointer :: function_pointer
+ integer :: value
+ ! F2028 C873 applies to function references as well as CALL statements.
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be passed to a procedure with an implicit interface
+ value = f(p)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be passed to a procedure with an implicit interface
+ value = dummy_function(p)
+ !ERROR: PROTECTED_TARGET pointer 'p' or its subobject may not be passed to a procedure with an implicit interface
+ value = function_pointer(p)
+ value = f((p))
+ end subroutine
+
+ subroutine value_arguments(p)
+ integer, pointer, protected_target :: p
+ ! F2028 C874 requires INTENT(IN) even for a VALUE dummy.
+ !ERROR: Nonpointer dummy argument 'x=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'p' or its subobject
+ call by_value(p)
+ call by_value_in(p)
+ end subroutine
+ subroutine by_value(x)
+ integer, value :: x
+ end subroutine
+ subroutine by_value_in(x)
+ integer, value, intent(in) :: x
+ end subroutine
+
+ subroutine intrinsic_calls(p, array, text)
+ use iso_c_binding, only: c_ptr, c_loc, c_f_pointer
+ integer, pointer, protected_target :: p
+ real, pointer, protected_target :: array(:)
+ character(10), pointer, protected_target :: text
+ type(c_ptr) :: address
+ logical :: is_associated
+ integer :: extent
+ ! F2028 C874 applies to intrinsic INTENT(OUT) arguments.
+ !ERROR: Nonpointer dummy argument 'harvest=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'array' or its subobject
+ call random_number(array)
+ !ERROR: Nonpointer dummy argument 'date=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'text' or its subobject
+ call date_and_time(date=text)
+ ! FPTR is a pointer dummy without PROTECTED_TARGET (F2028 C872).
+ !ERROR: POINTER dummy argument 'fptr=' must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer 'p' or its subobject
+ call c_f_pointer(address, p)
+ address = c_loc(p)
+ is_associated = associated(p)
+ extent = size(array) + len(text)
+ p => null(mold=p)
+ end subroutine
+
+ subroutine ordinary_actual(writable)
+ integer, pointer :: writable
+ ! F2028 C872 constrains PROTECTED_TARGET actuals, not ordinary pointers.
+ call protected_out(writable)
+ end subroutine
+ subroutine protected_out(p)
+ integer, pointer, protected_target, intent(out) :: p
+ nullify(p)
+ 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 0000000000000..018219de94494
--- /dev/null
+++ b/flang/test/Semantics/protected-target05.f90
@@ -0,0 +1,170 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1 -pedantic
+
+! F2028 C866 applies to output specifiers and construct-associated names.
+subroutine output_specifiers(status, text, exists)
+ integer, pointer, protected_target :: status
+ character(20), pointer, protected_target :: text
+ logical, pointer, protected_target :: exists
+ integer, pointer :: p
+ integer :: value, istat
+ character(20) :: message
+ logical :: ordinary_exists
+ namelist /group/ status
+ !ERROR: STAT variable 'status' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'status' is not definable
+ allocate(p, source=1, stat=status)
+ !ERROR: ERRMSG variable 'text' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'text' is not definable
+ deallocate(p, stat=istat, errmsg=text)
+ !ERROR: EXIST variable 'exists' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'exists' is not definable
+ inquire(file='file', exist=exists)
+ !ERROR: IOMSG variable 'text' is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'text' is not definable
+ read(*, *, iostat=istat, iomsg=text) value
+ !ERROR: NAMELIST input group must not contain undefinable item 'status'
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'status' is not definable
+ read(*, nml=group)
+ write(*, nml=group)
+ read(text, *, iostat=istat) value
+ inquire(iolength=value) status
+ inquire(file='file', exist=ordinary_exists)
+ allocate(p, source=status, stat=istat, errmsg=message)
+ deallocate(p, stat=istat, errmsg=message)
+end subroutine
+
+subroutine locality(readonly, writable, n)
+ integer, pointer, protected_target :: readonly
+ integer, pointer :: writable
+ integer :: n, i
+ ! F2028 C1130/C1131 exclude objects forbidden in variable definition contexts.
+ !ERROR: 'readonly' may not appear in a locality-spec because it is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'readonly' is not definable
+ do concurrent (i=1:n) local(readonly)
+ end do
+ !ERROR: 'readonly' may not appear in a locality-spec because it is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'readonly' is not definable
+ do concurrent (i=1:n) local_init(readonly)
+ end do
+ !ERROR: 'readonly' may not appear in a locality-spec because it is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'readonly' is not definable
+ do concurrent (i=1:n) reduce(+:readonly)
+ end do
+ do concurrent (i=1:n) shared(readonly)
+ print *, readonly
+ end do
+ do concurrent (i=1:n) local(writable)
+ end do
+end subroutine
+
+subroutine construct_association(polymorphic, assumed_rank)
+ class(*), pointer, protected_target :: polymorphic
+ integer, pointer, protected_target :: assumed_rank(..)
+ interface
+ subroutine ordinary_pointer(p)
+ integer, pointer, intent(in) :: p(..)
+ end subroutine
+ subroutine default_intent(x)
+ integer :: x(..)
+ end subroutine
+ end interface
+ select type (value => polymorphic)
+ type is (integer)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'polymorphic' is not definable
+ value = 1
+ print *, value
+ end select
+ select rank (value => assumed_rank)
+ rank (0)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'assumed_rank' is not definable
+ value = 1
+ print *, value
+ rank (1)
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'assumed_rank' is not definable
+ value(1) = 1
+ print *, value
+ !WARNING: Pointer target is not a definable variable [-Wpointer-to-undefinable]
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'assumed_rank' is not definable
+ call ordinary_pointer(value)
+ call default_intent(value)
+ rank default
+ ! F2028 C872
+ !ERROR: POINTER dummy argument 'p=' must have PROTECTED_TARGET to accept PROTECTED_TARGET pointer 'assumed_rank' or its subobject
+ call ordinary_pointer(value)
+ ! F2028 C874
+ !ERROR: Nonpointer dummy argument 'x=' must have INTENT(IN) to accept PROTECTED_TARGET pointer 'assumed_rank' or its subobject
+ call default_intent(value)
+ end select
+end subroutine
+
+subroutine array_definitions(readonly, writable)
+ integer, pointer, protected_target :: readonly(:)
+ integer, pointer :: writable(:)
+ integer :: i
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'readonly' is not definable
+ forall (i=1:2) readonly(i) = i
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'readonly' is not definable
+ where (readonly > 0) readonly = 0
+ forall (i=1:2) writable(i) = readonly(i)
+ where (readonly > 0) writable = 0
+end subroutine
+
+subroutine selector_bounds(n, m, indices, ordinary_indices, text, &
+ readonly_text, array, z, coarray)
+ integer, pointer, protected_target :: n, indices(:)
+ integer, pointer :: m, ordinary_indices(:)
+ character(20) :: text
+ character(20), pointer, protected_target :: readonly_text
+ integer :: array(10)
+ complex :: z(10)
+ integer :: coarray[*]
+ ! Bounds are read; only the selector's parent is defined.
+ associate (a => text(n:n))
+ a = 'x'
+ end associate
+ associate (a => text(m:m))
+ a = 'x'
+ end associate
+ associate (a => readonly_text(n:n))
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'readonly_text' is not definable
+ a = 'x'
+ end associate
+ text(n:n) = 'x'
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Target of PROTECTED_TARGET pointer 'readonly_text' is not definable
+ readonly_text(n:n) = 'x'
+ associate (a => array(n))
+ a = 1
+ end associate
+ associate (a => array(n:n:n))
+ a = 1
+ end associate
+ associate (a => array(indices))
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Construct association 'a' has a vector subscript
+ a = 1
+ end associate
+ associate (a => array(ordinary_indices))
+ !ERROR: Left-hand side of assignment is not definable
+ !BECAUSE: Construct association 'a' has a vector subscript
+ a = 1
+ end associate
+ array(n) = 1
+ array(n:n:n) = 1
+ array(indices) = 1
+ associate (a => z(n)%re)
+ a = 1.
+ end associate
+ z(n)%im = 1.
+ !ERROR: Selector must not be a coindexed object
+ associate (a => coarray[n])
+ print *, a
+ end associate
+ coarray[n] = 1
+end subroutine
More information about the flang-commits
mailing list