name, characteristics::Procedure{std::move(dummyArgs), attrs}},
std::move(rearranged)};
} else {
+ attrs.set(characteristics::Procedure::Attr::Pure);
characteristics::TypeAndShape typeAndShape{resultType.value(), resultRank};
characteristics::FunctionResult funcResult{std::move(typeAndShape)};
characteristics::Procedure chars{
}
parser::Message *AttachDeclaration(
- parser::Message *message, const Symbol *symbol) {
- if (message && symbol) {
+ parser::Message &message, const Symbol *symbol) {
+ if (symbol) {
const Symbol *unhosted{symbol};
while (
const auto *assoc{unhosted->detailsIf<semantics::HostAssocDetails>()}) {
unhosted = &assoc->symbol();
}
if (const auto *use{symbol->detailsIf<semantics::UseDetails>()}) {
- message->Attach(use->location(),
+ message.Attach(use->location(),
"'%s' is USE-associated with '%s' in module '%s'"_en_US,
symbol->name(), unhosted->name(), use->module().name());
} else {
- message->Attach(
+ message.Attach(
unhosted->name(), "Declaration of '%s'"_en_US, symbol->name());
}
}
+ return &message;
+}
+
+parser::Message *AttachDeclaration(
+ parser::Message *message, const Symbol *symbol) {
+ if (message) {
+ AttachDeclaration(*message, symbol);
+ }
return message;
}
}
// Utilities for attaching the location of the declaration of a symbol
// of interest to a message, if both pointers are non-null. Handles
// the case of USE association gracefully.
+parser::Message *AttachDeclaration(parser::Message &, const Symbol *);
parser::Message *AttachDeclaration(parser::Message *, const Symbol *);
-template<typename... A>
+template<typename MESSAGES, typename... A>
parser::Message *SayWithDeclaration(
- parser::ContextualMessages &messages, const Symbol *symbol, A &&... x) {
+ MESSAGES &messages, const Symbol *symbol, A &&... x) {
return AttachDeclaration(messages.Say(std::forward<A>(x)...), symbol);
}
}
check-io.cc
check-nullify.cc
check-omp-structure.cc
+ check-purity.cc
check-return.cc
check-stop.cc
expression.cc
class AssignmentContext {
public:
- explicit AssignmentContext(
- SemanticsContext &c, parser::CharBlock at = parser::CharBlock{})
- : context_{c}, messages_{at, &c.messages()} {}
+ explicit AssignmentContext(SemanticsContext &c) : context_{c} {}
AssignmentContext(const AssignmentContext &c, WhereContext &w)
- : context_{c.context_}, messages_{c.messages_}, where_{&w} {}
+ : context_{c.context_}, at_{c.at_}, where_{&w} {}
AssignmentContext(const AssignmentContext &c, ForallContext &f)
- : context_{c.context_}, messages_{c.messages_}, forall_{&f} {}
+ : context_{c.context_}, at_{c.at_}, forall_{&f} {}
bool operator==(const AssignmentContext &x) const { return this == &x; }
+ void set_at(parser::CharBlock at) { at_ = at; }
+
void Analyze(const parser::AssignmentStmt &);
void Analyze(const parser::PointerAssignmentStmt &);
void Analyze(const parser::WhereStmt &);
void Analyze(const parser::WhereConstruct::Elsewhere &);
void Analyze(const parser::ForallAssignmentStmt &stmt) { Analyze(stmt.u); }
+ const Symbol *FindPureProcedureContaining(parser::CharBlock) const;
int GetIntegerKind(const std::optional<parser::IntegerTypeSpec> &);
MaskExpr GetMask(const parser::LogicalExpr &, bool defaultValue = true) const;
- template<typename... A> parser::Message *Say(A &&... args) {
- return messages_.Say(std::forward<A>(args)...);
+ template<typename... A>
+ parser::Message *Say(parser::CharBlock at, A &&... args) {
+ return &context_.messages().Say(at, std::forward<A>(args)...);
}
SemanticsContext &context_;
- parser::ContextualMessages messages_;
+ parser::CharBlock at_;
WhereContext *where_{nullptr};
ForallContext *forall_{nullptr};
};
-void AssignmentContext::Analyze(const parser::AssignmentStmt &) {
+void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
if (forall_) {
// TODO: Warn if some name in forall_->activeNames or its outer
// contexts does not appear on LHS
}
// TODO: Fortran 2003 ALLOCATABLE assignment semantics (automatic
// (re)allocation of LHS array when unallocated or nonconformable)
+
+ // C1596 checks for polymorphic deallocation in a PURE subprogram
+ // due to automatic reallocation on assignment
+ const auto &lhs{std::get<parser::Variable>(stmt.t)};
+ const auto &rhs{std::get<parser::Expr>(stmt.t)};
+ if (auto lhsExpr{AnalyzeExpr(context_, lhs)}) {
+ if (auto type{evaluate::DynamicType::From(*lhsExpr)}) {
+ if (type->IsPolymorphic() && lhsExpr->Rank() > 0) {
+ if (const Symbol * last{evaluate::GetLastSymbol(*lhsExpr)}) {
+ if (IsAllocatable(*last) && FindPureProcedureContaining(rhs.source)) {
+ evaluate::SayWithDeclaration(context_.messages(), last, at_,
+ "Deallocation of polymorphic object '%s' is not permitted in a PURE subprogram"_err_en_US,
+ last->name());
+ }
+ }
+ }
+ if (type->category() == TypeCategory::Derived &&
+ !type->IsUnlimitedPolymorphic() /* TODO */ &&
+ FindPureProcedureContaining(rhs.source)) {
+ if (auto bad{FindPolymorphicAllocatableUltimateComponent(
+ type->GetDerivedTypeSpec())}) {
+ evaluate::SayWithDeclaration(context_.messages(), &*bad, at_,
+ "Deallocation of polymorphic component '%s' is not permitted in a PURE subprogram"_err_en_US,
+ bad.BuildResultDesignatorName());
+ }
+ }
+ }
+ }
}
void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &) {
const auto &assign{
std::get<parser::UnlabeledStatement<parser::ForallAssignmentStmt>>(
stmt.t)};
- auto restorer{nested.messages_.SetLocation(assign.source)};
+ nested.set_at(assign.source);
nested.Analyze(assign.statement);
}
if (auto value{evaluate::ToInt64(kind)}) {
return static_cast<int>(*value);
} else {
- Say("Kind of INTEGER type must be a constant value"_err_en_US);
+ Say(at_, "Kind of INTEGER type must be a constant value"_err_en_US);
return context_.GetDefaultKind(TypeCategory::Integer);
}
}
return mask;
}
+const Symbol *AssignmentContext::FindPureProcedureContaining(
+ parser::CharBlock source) const {
+
+ if (const semantics::Scope *
+ pure{semantics::FindPureProcedureContaining(
+ &context_.FindScope(source))}) {
+ return pure->symbol();
+ } else {
+ return nullptr;
+ }
+}
+
void AnalyzeConcurrentHeader(
SemanticsContext &context, const parser::ConcurrentHeader &header) {
AssignmentContext{context}.Analyze(header);
}
-AssignmentChecker::~AssignmentChecker() = default;
+AssignmentChecker::~AssignmentChecker() {}
AssignmentChecker::AssignmentChecker(SemanticsContext &context)
: context_{new AssignmentContext{context}} {}
void AssignmentChecker::Enter(const parser::AssignmentStmt &x) {
+ context_.value().set_at(at_);
context_.value().Analyze(x);
}
void AssignmentChecker::Enter(const parser::PointerAssignmentStmt &x) {
+ context_.value().set_at(at_);
context_.value().Analyze(x);
}
void AssignmentChecker::Enter(const parser::WhereStmt &x) {
+ context_.value().set_at(at_);
context_.value().Analyze(x);
}
void AssignmentChecker::Enter(const parser::WhereConstruct &x) {
+ context_.value().set_at(at_);
context_.value().Analyze(x);
}
void AssignmentChecker::Enter(const parser::ForallStmt &x) {
+ context_.value().set_at(at_);
context_.value().Analyze(x);
}
void AssignmentChecker::Enter(const parser::ForallConstruct &x) {
+ context_.value().set_at(at_);
context_.value().Analyze(x);
}
-
-namespace {
-class Visitor {
-public:
- Visitor(SemanticsContext &context) : context_{context} {}
-
- template<typename A> bool Pre(const A &) { return true /* visit children */; }
- template<typename A> void Post(const A &) {}
-
- bool Pre(const parser::Statement<parser::AssignmentStmt> &stmt) {
- AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
- return false;
- }
- bool Pre(const parser::Statement<parser::PointerAssignmentStmt> &stmt) {
- AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
- return false;
- }
- bool Pre(const parser::Statement<parser::WhereStmt> &stmt) {
- AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
- return false;
- }
- bool Pre(const parser::WhereConstruct &construct) {
- AssignmentContext{context_}.Analyze(construct);
- return false;
- }
- bool Pre(const parser::Statement<parser::ForallStmt> &stmt) {
- AssignmentContext{context_, stmt.source}.Analyze(stmt.statement);
- return false;
- }
- bool Pre(const parser::ForallConstruct &construct) {
- AssignmentContext{context_}.Analyze(construct);
- return false;
- }
-
-private:
- SemanticsContext &context_;
-};
-}
}
template class Fortran::common::Indirection<
Fortran::semantics::AssignmentContext>;
public:
explicit AssignmentChecker(SemanticsContext &);
~AssignmentChecker();
+ template<typename A> void Enter(const parser::Statement<A> &stmt) {
+ at_ = stmt.source;
+ }
void Enter(const parser::AssignmentStmt &);
void Enter(const parser::PointerAssignmentStmt &);
void Enter(const parser::WhereStmt &);
private:
common::Indirection<AssignmentContext> context_;
+ parser::CharBlock at_;
};
// Semantic analysis of an assignment statement or WHERE/FORALL construct.
dummyName, finalizer->name());
}
}
- UltimateComponentIterator ultimates{derived};
if (actualIsCoindexed) {
if (dummy.intent != common::Intent::In && !dummyIsValue) {
- if (auto iter{std::find_if(ultimates.begin(), ultimates.end(),
- [](const Symbol &component) {
- return IsAllocatable(component);
- })}) { // 15.5.2.4(6)
- evaluate::SayWithDeclaration(messages, &*iter,
+ if (auto bad{
+ FindAllocatableUltimateComponent(derived)}) { // 15.5.2.4(6)
+ evaluate::SayWithDeclaration(messages, &*bad,
"Coindexed actual argument with ALLOCATABLE ultimate component '%s' must be associated with a %s with VALUE or INTENT(IN) attributes"_err_en_US,
- iter.BuildResultDesignatorName(), dummyName);
+ bad.BuildResultDesignatorName(), dummyName);
}
}
if (auto coarrayRef{evaluate::ExtractCoarrayRef(actual)}) { // C1537
const Symbol &coarray{coarrayRef->GetLastSymbol()};
if (const DeclTypeSpec * type{coarray.GetType()}) {
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
- if (auto ptr{semantics::FindPointerUltimateComponent(*derived)}) {
+ if (auto bad{semantics::FindPointerUltimateComponent(*derived)}) {
evaluate::SayWithDeclaration(messages, &coarray,
"Coindexed object '%s' with POINTER ultimate component '%s' cannot be associated with %s"_err_en_US,
- coarray.name(), ptr->name(), dummyName);
+ coarray.name(), bad.BuildResultDesignatorName(), dummyName);
}
}
}
}
}
if (actualIsVolatile != dummyIsVolatile) { // 15.5.2.4(22)
- if (auto iter{std::find_if(
- ultimates.begin(), ultimates.end(), [](const Symbol &component) {
- const auto *object{component.detailsIf<ObjectEntityDetails>()};
- return object && object->IsCoarray();
- })}) {
- evaluate::SayWithDeclaration(messages, &*iter,
+ if (auto bad{semantics::FindCoarrayUltimateComponent(derived)}) {
+ evaluate::SayWithDeclaration(messages, &*bad,
"VOLATILE attribute must match for %s when actual argument has a coarray ultimate component '%s'"_err_en_US,
- dummyName, iter.BuildResultDesignatorName());
+ dummyName, bad.BuildResultDesignatorName());
}
}
}
evaluate::ActualArguments &, evaluate::FoldingContext &, const Scope &,
bool treatingExternalAsImplicit = false);
-// Check actual arguments against a procedure with an explicit interface.
+// Checks actual arguments against a procedure with an explicit interface.
// Reports a buffer of errors when not compatible.
parser::Messages CheckExplicitInterface(
const evaluate::characteristics::Procedure &, evaluate::ActualArguments &,
const evaluate::FoldingContext &, const Scope &);
-// Check actual arguments for the purpose of resolving a generic interface.
+
+// Checks actual arguments for the purpose of resolving a generic interface.
bool CheckInterfaceForGeneric(const evaluate::characteristics::Procedure &,
evaluate::ActualArguments &, const evaluate::FoldingContext &);
}
#include "type.h"
#include "../evaluate/check-expression.h"
#include "../evaluate/fold.h"
+#include "../evaluate/tools.h"
namespace Fortran::semantics {
evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
parser::ContextualMessages &messages_{foldingContext_.messages()};
const Scope *scope_{nullptr};
- bool inBindC_{false}; // scope is BIND(C)
- bool inPure_{false}; // scope is PURE
+ // This symbol is the one attached to the innermost enclosing scope
+ // that has a symbol.
+ const Symbol *innermostSymbol_{nullptr};
};
void CheckHelper::Check(const ParamValue &value, bool canBeAssumed) {
return;
}
const DeclTypeSpec *type{symbol.GetUltimate().GetType()};
- const DerivedTypeSpec *derived{nullptr};
- if (type) {
- derived = type->AsDerived();
- }
+ const DerivedTypeSpec *derived{type ? type->AsDerived() : nullptr};
auto save{messages_.SetLocation(symbol.name())};
context_.set_location(symbol.name());
bool isAssociated{symbol.has<UseDetails>() || symbol.has<HostAssocDetails>()};
if (isAssociated) {
return; // only care about checking VOLATILE on associated symbols
}
+ bool inPure{innermostSymbol_ && IsPureProcedure(*innermostSymbol_)};
+ if (inPure) {
+ if (IsSaved(symbol)) {
+ messages_.Say(
+ "A PURE subprogram may not have a variable with the SAVE attribute"_err_en_US);
+ }
+ if (symbol.attrs().test(Attr::VOLATILE)) {
+ messages_.Say(
+ "A PURE subprogram may not have a variable with the VOLATILE attribute"_err_en_US);
+ }
+ if (IsProcedure(symbol) && !IsPureProcedure(symbol) && IsDummy(symbol)) {
+ messages_.Say(
+ "A dummy procedure of a PURE subprogram must be PURE"_err_en_US);
+ }
+ if (!IsDummy(symbol) && !IsFunctionResult(symbol)) {
+ if (IsPolymorphicAllocatable(symbol)) {
+ evaluate::SayWithDeclaration(messages_, &symbol,
+ "Deallocation of polymorphic object '%s' is not permitted in a PURE subprogram"_err_en_US,
+ symbol.name());
+ } else if (derived) {
+ if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
+ evaluate::SayWithDeclaration(messages_, &*bad,
+ "Deallocation of polymorphic object '%s%s' is not permitted in a PURE subprogram"_err_en_US,
+ symbol.name(), bad.BuildResultDesignatorName());
+ }
+ }
+ }
+ }
+ bool inFunction{innermostSymbol_ && IsFunction(*innermostSymbol_)};
if (type) {
bool canHaveAssumedParameter{IsNamedConstant(symbol) ||
IsAssumedLengthCharacterFunction(symbol) ||
canHaveAssumedParameter |= symbol.has<AssocEntityDetails>();
}
Check(*type, canHaveAssumedParameter);
+ if (inPure && inFunction && IsFunctionResult(symbol)) {
+ if (derived && HasImpureFinal(*derived)) { // C1584
+ messages_.Say(
+ "Result of PURE function may not have an impure FINAL subroutine"_err_en_US);
+ }
+ if (type->IsPolymorphic() && IsAllocatable(symbol)) { // C1585
+ messages_.Say(
+ "Result of PURE function may not be both polymorphic and ALLOCATABLE"_err_en_US);
+ }
+ if (derived) {
+ if (auto bad{FindPolymorphicAllocatableUltimateComponent(*derived)}) {
+ evaluate::SayWithDeclaration(messages_, &*bad,
+ "Result of PURE function may not have polymorphic ALLOCATABLE ultimate component '%s'"_err_en_US,
+ bad.BuildResultDesignatorName());
+ }
+ }
+ }
}
if (IsAssumedLengthCharacterFunction(symbol)) { // C723
if (symbol.attrs().test(Attr::RECURSIVE)) {
}
}
}
- if (object->isDummy() && symbol.attrs().test(Attr::INTENT_OUT)) {
- if (FindUltimateComponent(symbol, [](const Symbol &symbol) {
- return IsCoarray(symbol) && IsAllocatable(symbol);
- })) { // C846
- messages_.Say(
- "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
+ if (object->isDummy()) {
+ if (symbol.attrs().test(Attr::INTENT_OUT)) {
+ if (FindUltimateComponent(symbol, [](const Symbol &x) {
+ return IsCoarray(x) && IsAllocatable(x);
+ })) { // C846
+ messages_.Say(
+ "An INTENT(OUT) dummy argument may not be, or contain, an ALLOCATABLE coarray"_err_en_US);
+ }
+ if (IsOrContainsEventOrLockComponent(symbol)) { // C847
+ messages_.Say(
+ "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
+ }
}
- if (IsOrContainsEventOrLockComponent(symbol)) { // C847
- messages_.Say(
- "An INTENT(OUT) dummy argument may not be, or contain, EVENT_TYPE or LOCK_TYPE"_err_en_US);
+ if (inPure && !IsPointer(symbol) && !IsIntentIn(symbol) &&
+ !symbol.attrs().test(Attr::VALUE)) {
+ if (inFunction) { // C1583
+ messages_.Say(
+ "non-POINTER dummy argument of PURE function must be INTENT(IN) or VALUE"_err_en_US);
+ } else if (IsIntentOut(symbol)) {
+ if (type && type->IsPolymorphic()) { // C1588
+ messages_.Say(
+ "An INTENT(OUT) dummy argument of a PURE subroutine may not be polymorphic"_err_en_US);
+ } else if (derived) {
+ if (FindUltimateComponent(*derived, [](const Symbol &x) {
+ const DeclTypeSpec *type{x.GetType()};
+ return type && type->IsPolymorphic();
+ })) { // C1588
+ messages_.Say(
+ "An INTENT(OUT) dummy argument of a PURE subroutine may not have a polymorphic ultimate component"_err_en_US);
+ }
+ if (HasImpureFinal(*derived)) { // C1587
+ messages_.Say(
+ "An INTENT(OUT) dummy argument of a PURE subroutine may not have an impure FINAL subroutine"_err_en_US);
+ }
+ }
+ } else if (!IsIntentInOut(symbol)) { // C1586
+ messages_.Say(
+ "non-POINTER dummy argument of PURE subroutine must have INTENT() or VALUE attribute"_err_en_US);
+ }
}
}
} else if (auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
if (symbol.attrs().test(Attr::VOLATILE)) {
messages_.Say("VALUE attribute may not apply to a VOLATILE"_err_en_US);
}
- if (inBindC_ && IsOptional(symbol)) {
+ if (innermostSymbol_ && IsBindCProcedure(*innermostSymbol_) &&
+ IsOptional(symbol)) {
messages_.Say(
"VALUE attribute may not apply to an OPTIONAL in a BIND(C) procedure"_err_en_US);
}
void CheckHelper::Check(const Scope &scope) {
scope_ = &scope;
- inBindC_ = IsBindCProcedure(scope);
- inPure_ = IsPureProcedure(scope);
+ if (const Symbol * scopeSymbol{scope.symbol()}) {
+ innermostSymbol_ = scopeSymbol;
+ }
for (const auto &pair : scope) {
Check(*pair.second);
}
}
void IoChecker::Leave(const parser::BackspaceStmt &) {
+ CheckForPureSubprogram();
CheckForRequiredSpecifier(
flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
stmt_ = IoStmtKind::None;
}
void IoChecker::Leave(const parser::CloseStmt &) {
+ CheckForPureSubprogram();
CheckForRequiredSpecifier(
flags_.test(Flag::NumberUnit), "UNIT number"); // C1208
stmt_ = IoStmtKind::None;
}
void IoChecker::Leave(const parser::EndfileStmt &) {
+ CheckForPureSubprogram();
CheckForRequiredSpecifier(
flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
stmt_ = IoStmtKind::None;
}
void IoChecker::Leave(const parser::FlushStmt &) {
+ CheckForPureSubprogram();
CheckForRequiredSpecifier(
flags_.test(Flag::NumberUnit), "UNIT number"); // C1243
stmt_ = IoStmtKind::None;
void IoChecker::Leave(const parser::InquireStmt &stmt) {
if (std::get_if<std::list<parser::InquireSpec>>(&stmt.u)) {
+ CheckForPureSubprogram();
// Inquire by unit or by file (vs. by output list).
CheckForRequiredSpecifier(
flags_.test(Flag::NumberUnit) || specifierSet_.test(IoSpecKind::File),
}
void IoChecker::Leave(const parser::OpenStmt &) {
+ CheckForPureSubprogram();
CheckForRequiredSpecifier(specifierSet_.test(IoSpecKind::Unit) ||
specifierSet_.test(IoSpecKind::Newunit),
"UNIT or NEWUNIT"); // C1204, C1205
stmt_ = IoStmtKind::None;
}
-void IoChecker::Leave(const parser::PrintStmt &) { stmt_ = IoStmtKind::None; }
+void IoChecker::Leave(const parser::PrintStmt &) {
+ CheckForPureSubprogram();
+ stmt_ = IoStmtKind::None;
+}
void IoChecker::Leave(const parser::ReadStmt &) {
+ if (!flags_.test(Flag::InternalUnit)) {
+ CheckForPureSubprogram();
+ }
if (!flags_.test(Flag::IoControlList)) {
return;
}
void IoChecker::Leave(const parser::RewindStmt &) {
CheckForRequiredSpecifier(
flags_.test(Flag::NumberUnit), "UNIT number"); // C1240
+ CheckForPureSubprogram();
stmt_ = IoStmtKind::None;
}
void IoChecker::Leave(const parser::WaitStmt &) {
CheckForRequiredSpecifier(
flags_.test(Flag::NumberUnit), "UNIT number"); // C1237
+ CheckForPureSubprogram();
stmt_ = IoStmtKind::None;
}
void IoChecker::Leave(const parser::WriteStmt &) {
+ if (!flags_.test(Flag::InternalUnit)) {
+ CheckForPureSubprogram();
+ }
LeaveReadWrite();
CheckForProhibitedSpecifier(IoSpecKind::Blank); // C1213
CheckForProhibitedSpecifier(IoSpecKind::End); // C1213
}
}
+void IoChecker::CheckForPureSubprogram() const { // C1597
+ CHECK(context_.location());
+ if (FindPureProcedureContaining(&context_.FindScope(*context_.location()))) {
+ context_.Say("External I/O is not allowed in a PURE subprogram"_err_en_US);
+ }
+}
+
} // namespace Fortran::semantics
flags_.reset();
}
+ void CheckForPureSubprogram() const;
+
SemanticsContext &context_;
IoStmtKind stmt_ = IoStmtKind::None;
common::EnumSet<IoSpecKind, common::IoSpecKind_enumSize> specifierSet_;
--- /dev/null
+// Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+
+#include "check-purity.h"
+#include "tools.h"
+#include "../parser/parse-tree.h"
+
+namespace Fortran::semantics {
+void PurityChecker::Enter(const parser::ExecutableConstruct &exec) {
+ if (InPureSubprogram() && IsImageControlStmt(exec)) {
+ context_.Say(GetImageControlStmtLocation(exec),
+ "An image control statement may not appear in a PURE subprogram"_err_en_US);
+ }
+}
+void PurityChecker::Enter(const parser::SubroutineSubprogram &subr) {
+ const auto &stmt{std::get<parser::Statement<parser::SubroutineStmt>>(subr.t)};
+ Entered(
+ stmt.source, std::get<std::list<parser::PrefixSpec>>(stmt.statement.t));
+}
+
+void PurityChecker::Leave(const parser::SubroutineSubprogram &) { Left(); }
+
+void PurityChecker::Enter(const parser::FunctionSubprogram &func) {
+ const auto &stmt{std::get<parser::Statement<parser::FunctionStmt>>(func.t)};
+ Entered(
+ stmt.source, std::get<std::list<parser::PrefixSpec>>(stmt.statement.t));
+}
+
+void PurityChecker::Leave(const parser::FunctionSubprogram &) { Left(); }
+
+bool PurityChecker::InPureSubprogram() const {
+ return pureDepth_ >= 0 && depth_ >= pureDepth_;
+}
+
+bool PurityChecker::HasPurePrefix(
+ const std::list<parser::PrefixSpec> &prefixes) const {
+ for (const parser::PrefixSpec &prefix : prefixes) {
+ if (std::holds_alternative<parser::PrefixSpec::Pure>(prefix.u)) {
+ return true;
+ }
+ }
+ return false;
+}
+
+void PurityChecker::Entered(
+ parser::CharBlock source, const std::list<parser::PrefixSpec> &prefixes) {
+ if (depth_ == 2) {
+ context_.messages().Say(source,
+ "An internal subprogram may not contain an internal subprogram"_err_en_US);
+ }
+ if (HasPurePrefix(prefixes)) {
+ if (pureDepth_ < 0) {
+ pureDepth_ = depth_;
+ }
+ } else if (InPureSubprogram()) {
+ context_.messages().Say(source,
+ "An internal subprogram of a PURE subprogram must also be PURE"_err_en_US);
+ }
+ ++depth_;
+}
+
+void PurityChecker::Left() {
+ if (pureDepth_ == --depth_) {
+ pureDepth_ = -1;
+ }
+}
+
+}
--- /dev/null
+// Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+
+#ifndef FORTRAN_SEMANTICS_CHECK_PURITY_H_
+#define FORTRAN_SEMANTICS_CHECK_PURITY_H_
+#include "semantics.h"
+#include <list>
+namespace Fortran::parser {
+struct ExecutableConstruct;
+struct SubroutineSubprogram;
+struct FunctionSubprogram;
+struct PrefixSpec;
+}
+namespace Fortran::semantics {
+class PurityChecker : public virtual BaseChecker {
+public:
+ explicit PurityChecker(SemanticsContext &c) : context_{c} {}
+ void Enter(const parser::ExecutableConstruct &);
+ void Enter(const parser::SubroutineSubprogram &);
+ void Leave(const parser::SubroutineSubprogram &);
+ void Enter(const parser::FunctionSubprogram &);
+ void Leave(const parser::FunctionSubprogram &);
+
+private:
+ bool InPureSubprogram() const;
+ bool HasPurePrefix(const std::list<parser::PrefixSpec> &) const;
+ void Entered(parser::CharBlock, const std::list<parser::PrefixSpec> &);
+ void Left();
+ SemanticsContext &context_;
+ int depth_{0};
+ int pureDepth_{-1};
+};
+}
+#endif
// derived type definition)
return AsMaybeExpr(MakeBareTypeParamInquiry(&ultimate));
} else {
+ if (n.symbol->attrs().test(semantics::Attr::VOLATILE)) {
+ if (const semantics::Scope *
+ pure{semantics::FindPureProcedureContaining(
+ &context_.FindScope(n.source))}) {
+ SayAt(n,
+ "VOLATILE variable '%s' may not be referenced in PURE subprogram '%s'"_err_en_US,
+ n.source, DEREF(pure->symbol()).name());
+ n.symbol->attrs().reset(semantics::Attr::VOLATILE);
+ }
+ }
return Designate(DataRef{*n.symbol});
}
}
}
semantics::CheckArguments(*chars, arguments, GetFoldingContext(),
context_.FindScope(callSite), treatExternalAsImplicit);
+ if (!chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
+ if (const semantics::Scope *
+ pure{semantics::FindPureProcedureContaining(
+ &context_.FindScope(callSite))}) {
+ Say(callSite,
+ "Procedure referenced in PURE subprogram '%s' must be PURE too"_err_en_US,
+ DEREF(pure->symbol()).name());
+ }
+ }
}
return chars;
}
namespace Fortran::semantics {
-// Semantic analysis of one expression.
+// Semantic analysis of one expression, variable, or designator.
template<typename A>
std::optional<evaluate::Expr<evaluate::SomeType>> AnalyzeExpr(
SemanticsContext &context, const A &expr) {
#include "check-io.h"
#include "check-nullify.h"
#include "check-omp-structure.h"
+#include "check-purity.h"
#include "check-return.h"
#include "check-stop.h"
#include "expression.h"
using StatementSemanticsPass2 = SemanticsVisitor<AllocateChecker,
ArithmeticIfStmtChecker, AssignmentChecker, CoarrayChecker,
DeallocateChecker, DoChecker, IfStmtChecker, IoChecker, NullifyChecker,
- OmpStructureChecker, ReturnStmtChecker, StopChecker>;
+ OmpStructureChecker, PurityChecker, ReturnStmtChecker, StopChecker>;
static bool PerformStatementSemantics(
SemanticsContext &context, parser::Program &program) {
MaybeExpr bindName_;
};
-class FinalProcDetails {};
+class FinalProcDetails {}; // TODO
class MiscDetails {
public:
[](const GenericDetails &) { return true; },
[](const ProcBindingDetails &) { return true; },
[](const UseDetails &x) { return IsProcedure(x.symbol()); },
+ // TODO: FinalProcDetails?
[](const auto &) { return false; },
},
symbol.details());
return false; // this is a component
} else if (symbol.attrs().test(Attr::SAVE)) {
return true;
- } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
- return object->init().has_value();
- } else if (IsProcedurePointer(symbol)) {
- return symbol.get<ProcEntityDetails>().init().has_value();
} else {
+ if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (object->init()) {
+ return true;
+ }
+ } else if (IsProcedurePointer(symbol)) {
+ if (symbol.get<ProcEntityDetails>().init()) {
+ return true;
+ }
+ }
+ if (const Symbol * block{FindCommonBlockContaining(symbol)}) {
+ if (block->attrs().test(Attr::SAVE)) {
+ return true;
+ }
+ }
return false;
}
}
bool IsFinalizable(const Symbol &symbol) {
if (const DeclTypeSpec * type{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
- if (const Scope * scope{derived->scope()}) {
- for (auto &pair : *scope) {
- Symbol &symbol{*pair.second};
- if (symbol.has<FinalProcDetails>()) {
- return true;
- }
- }
- }
+ return IsFinalizable(*derived);
}
}
return false;
}
+bool IsFinalizable(const DerivedTypeSpec &derived) {
+ ScopeComponentIterator components{derived};
+ return std::find_if(components.begin(), components.end(),
+ [](const Symbol &x) { return x.has<FinalProcDetails>(); }) !=
+ components.end();
+}
+
+bool HasImpureFinal(const DerivedTypeSpec &derived) {
+ ScopeComponentIterator components{derived};
+ return std::find_if(
+ components.begin(), components.end(), [](const Symbol &x) {
+ return x.has<FinalProcDetails>() && !x.attrs().test(Attr::PURE);
+ }) != components.end();
+}
+
bool IsCoarray(const Symbol &symbol) { return symbol.Corank() > 0; }
bool IsAssumedLengthCharacter(const Symbol &symbol) {
return symbol.has<SubprogramDetails>() && IsAssumedLengthCharacter(symbol);
}
-bool IsExternalInPureContext(const Symbol &symbol, const Scope &scope) {
+const Symbol *IsExternalInPureContext(
+ const Symbol &symbol, const Scope &scope) {
if (const auto *pureProc{semantics::FindPureProcedureContaining(&scope)}) {
if (const Symbol * root{GetAssociationRoot(symbol)}) {
- if (FindExternallyVisibleObject(*root, *pureProc)) {
- return true;
+ if (const Symbol *
+ visible{FindExternallyVisibleObject(*root, *pureProc)}) {
+ return visible;
}
}
}
- return false;
+ return nullptr;
}
bool InProtectedContext(const Symbol &symbol, const Scope ¤tScope) {
return {};
}
-struct ImageControlStmtHelper {
+class ImageControlStmtHelper {
using ImageControlStmts = std::variant<parser::ChangeTeamConstruct,
parser::CriticalConstruct, parser::EventPostStmt, parser::EventWaitStmt,
parser::FormTeamStmt, parser::LockStmt, parser::StopStmt,
parser::SyncAllStmt, parser::SyncImagesStmt, parser::SyncMemoryStmt,
parser::SyncTeamStmt, parser::UnlockStmt>;
+
+public:
template<typename T> bool operator()(const T &) {
return common::HasMember<T, ImageControlStmts>;
}
template<typename T> bool operator()(const common::Indirection<T> &x) {
return (*this)(x.value());
}
- bool IsCoarrayObject(const parser::AllocateObject &allocateObject) {
- const parser::Name &name{GetLastName(allocateObject)};
- return name.symbol && IsCoarray(*name.symbol);
- }
bool operator()(const parser::AllocateStmt &stmt) {
const auto &allocationList{std::get<std::list<parser::Allocation>>(stmt.t)};
for (const auto &allocation : allocationList) {
bool operator()(const parser::Statement<parser::ActionStmt> &stmt) {
return std::visit(*this, stmt.statement.u);
}
+
+private:
+ bool IsCoarrayObject(const parser::AllocateObject &allocateObject) {
+ const parser::Name &name{GetLastName(allocateObject)};
+ return name.symbol && IsCoarray(*name.symbol);
+ }
};
bool IsImageControlStmt(const parser::ExecutableConstruct &construct) {
return std::nullopt;
}
-const parser::CharBlock GetImageControlStmtLocation(
+parser::CharBlock GetImageControlStmtLocation(
const parser::ExecutableConstruct &executableConstruct) {
return std::visit(
common::visitors{
return false;
}
+bool IsPolymorphicAllocatable(const Symbol &symbol) {
+ if (IsAllocatable(symbol)) {
+ if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (const DeclTypeSpec * type{details->type()}) {
+ return type->IsPolymorphic();
+ }
+ }
+ }
+ return false;
+}
+
static const DeclTypeSpec &InstantiateIntrinsicType(Scope &scope,
const DeclTypeSpec &spec, SemanticsContext &semanticsContext) {
const IntrinsicTypeSpec *intrinsic{spec.AsIntrinsic()};
traverse = !IsAllocatableOrPointer(component);
} else if constexpr (componentKind == ComponentKind::Potential) {
traverse = !IsPointer(component);
+ } else if constexpr (componentKind == ComponentKind::Scope) {
+ traverse = !IsAllocatableOrPointer(component);
}
if (traverse) {
const Symbol &newTypeSymbol{derived->typeSymbol()};
auto &nameIterator{deepest.nameIterator()};
if (nameIterator == deepest.nameEnd()) {
componentPath_.pop_back();
+ } else if constexpr (componentKind == ComponentKind::Scope) {
+ deepest.set_component(*nameIterator++->second);
+ deepest.set_descended(false);
+ deepest.set_visited(true);
+ return; // this is the next component to visit, before descending
} else {
const Scope &scope{deepest.GetScope()};
auto scopeIter{scope.find(*nameIterator++)};
template class ComponentIterator<ComponentKind::Direct>;
template class ComponentIterator<ComponentKind::Ultimate>;
template class ComponentIterator<ComponentKind::Potential>;
+template class ComponentIterator<ComponentKind::Scope>;
UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
const DerivedTypeSpec &derived) {
UltimateComponentIterator ultimates{derived};
- return std::find_if(ultimates.begin(), ultimates.end(),
- [](const Symbol &component) { return component.Corank() > 0; });
+ return std::find_if(ultimates.begin(), ultimates.end(), IsCoarray);
}
UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
const DerivedTypeSpec &derived) {
UltimateComponentIterator ultimates{derived};
- return std::find_if(ultimates.begin(), ultimates.end(),
- [](const Symbol &component) { return IsPointer(component); });
+ return std::find_if(ultimates.begin(), ultimates.end(), IsPointer);
}
PotentialComponentIterator::const_iterator FindEventOrLockPotentialComponent(
});
}
+UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
+ const DerivedTypeSpec &derived) {
+ UltimateComponentIterator ultimates{derived};
+ return std::find_if(ultimates.begin(), ultimates.end(), IsAllocatable);
+}
+
+UltimateComponentIterator::const_iterator
+FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &derived) {
+ UltimateComponentIterator ultimates{derived};
+ return std::find_if(
+ ultimates.begin(), ultimates.end(), IsPolymorphicAllocatable);
+}
+
const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived,
const std::function<bool(const Symbol &)> &predicate) {
UltimateComponentIterator ultimates{derived};
return symbol.attrs().test(Attr::PROTECTED);
}
bool IsFinalizable(const Symbol &);
+bool IsFinalizable(const DerivedTypeSpec &);
+bool HasImpureFinal(const DerivedTypeSpec &);
bool IsCoarray(const Symbol &);
inline bool IsAssumedSizeArray(const Symbol &symbol) {
const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
const Symbol &, const Scope &);
std::unique_ptr<parser::Message> WhyNotModifiable(SourceName, const SomeExpr &,
const Scope &, bool vectorSubscriptIsOk = false);
-bool IsExternalInPureContext(const Symbol &symbol, const Scope &scope);
-bool HasCoarray(const parser::Expr &expression);
+const Symbol *IsExternalInPureContext(const Symbol &, const Scope &);
+bool HasCoarray(const parser::Expr &);
+bool IsPolymorphicAllocatable(const Symbol &);
// Analysis of image control statements
bool IsImageControlStmt(const parser::ExecutableConstruct &);
// Get the location of the image control statement in this ExecutableConstruct
-const parser::CharBlock GetImageControlStmtLocation(
+parser::CharBlock GetImageControlStmtLocation(
const parser::ExecutableConstruct &);
// Image control statements that reference coarrays need an extra message
// to clarify why they're image control statements. This function returns
-// std::nullopt for ExecutableConstructs that do not require an extra message
+// std::nullopt for ExecutableConstructs that do not require an extra message.
std::optional<parser::MessageFixedText> GetImageControlStmtCoarrayMsg(
const parser::ExecutableConstruct &);
//
// Note that iterators are made in such a way that one can easily test and build
// info message in the following way:
-// ComponentIterator<ComponentIterator> comp{derived}
+// ComponentIterator<ComponentKind::...> comp{derived}
// if (auto it{std::find_if(comp.begin(), comp.end(), predicate)}) {
// msg = it.BuildResultDesignatorName() + " verifies predicates";
-// const Symbol* component{*it};
+// const Symbol *component{*it};
// ....
// }
-ENUM_CLASS(ComponentKind, Ordered, Direct, Ultimate, Potential)
+ENUM_CLASS(ComponentKind, Ordered, Direct, Ultimate, Potential, Scope)
template<ComponentKind componentKind> class ComponentIterator {
public:
std::string BuildResultDesignatorName() const;
private:
- using name_iterator = typename std::list<SourceName>::const_iterator;
+ using name_iterator =
+ std::conditional_t<componentKind == ComponentKind::Scope,
+ typename Scope::const_iterator,
+ typename std::list<SourceName>::const_iterator>;
class ComponentPathNode {
public:
explicit ComponentPathNode(const DerivedTypeSpec &derived)
: derived_{derived} {
- const std::list<SourceName> &nameList{
- derived.typeSymbol().get<DerivedTypeDetails>().componentNames()};
- nameIterator_ = nameList.cbegin();
- nameEnd_ = nameList.cend();
+ if constexpr (componentKind == ComponentKind::Scope) {
+ const Scope &scope{DEREF(derived.scope())};
+ nameIterator_ = scope.cbegin();
+ nameEnd_ = scope.cend();
+ } else {
+ const std::list<SourceName> &nameList{
+ derived.typeSymbol().get<DerivedTypeDetails>().componentNames()};
+ nameIterator_ = nameList.cbegin();
+ nameEnd_ = nameList.cend();
+ }
}
const Symbol *component() const { return component_; }
void set_component(const Symbol &component) { component_ = &component; }
extern template class ComponentIterator<ComponentKind::Direct>;
extern template class ComponentIterator<ComponentKind::Ultimate>;
extern template class ComponentIterator<ComponentKind::Potential>;
+extern template class ComponentIterator<ComponentKind::Scope>;
using OrderedComponentIterator = ComponentIterator<ComponentKind::Ordered>;
using DirectComponentIterator = ComponentIterator<ComponentKind::Direct>;
using UltimateComponentIterator = ComponentIterator<ComponentKind::Ultimate>;
using PotentialComponentIterator = ComponentIterator<ComponentKind::Potential>;
+using ScopeComponentIterator = ComponentIterator<ComponentKind::Scope>;
// Common component searches, the iterator returned is referring to the first
// component, according to the order defined for the related ComponentIterator,
const DerivedTypeSpec &);
UltimateComponentIterator::const_iterator FindPointerUltimateComponent(
const DerivedTypeSpec &);
+UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
+ const DerivedTypeSpec &);
+UltimateComponentIterator::const_iterator
+FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &);
}
#endif // FORTRAN_SEMANTICS_TOOLS_H_
call07.f90
call08.f90
call09.f90
+ call10.f90
call13.f90
call14.f90
misc-declarations.f90
type(t), intent(in) :: x
end subroutine
subroutine test
- !ERROR: Coindexed object 'coarray' with POINTER ultimate component 'ptr' cannot be associated with dummy argument 'x='
+ !ERROR: Coindexed object 'coarray' with POINTER ultimate component '%ptr' cannot be associated with dummy argument 'x='
call callee(coarray[1]) ! C1537
end subroutine
end module
real, pointer, intent(out) :: a ! ok if pointer
end function
pure real function f05(a) ! C1583
- real, intent(out), value :: a ! weird, but ok
+ real, value :: a ! weird, but ok (VALUE without INTENT)
end function
pure function f06() ! C1584
- !ERROR: Result of PURE function cannot have an impure FINAL procedure
+ !ERROR: Result of PURE function may not have an impure FINAL subroutine
type(impureFinal) :: f06
end function
pure function f07() ! C1585
- !ERROR: Result of PURE function cannot be both polymorphic and ALLOCATABLE
+ !ERROR: Result of PURE function may not be both polymorphic and ALLOCATABLE
class(t), allocatable :: f07
end function
pure function f08() ! C1585
- !ERROR: Result of PURE function cannot have a polymorphic ALLOCATABLE ultimate component
+ !ERROR: Result of PURE function may not have polymorphic ALLOCATABLE ultimate component '%a'
type(polyAlloc) :: f08
end function
real, pointer :: a
end subroutine
pure subroutine s02(a) ! C1587
- !ERROR: An INTENT(OUT) dummy argument of a PURE procedure cannot have an impure FINAL procedure
+ !ERROR: An INTENT(OUT) dummy argument of a PURE subroutine may not have an impure FINAL subroutine
type(impureFinal), intent(out) :: a
end subroutine
pure subroutine s03(a) ! C1588
- !ERROR: An INTENT(OUT) dummy argument of a PURE procedure cannot be polymorphic
+ !ERROR: An INTENT(OUT) dummy argument of a PURE subroutine may not be polymorphic
class(t), intent(out) :: a
end subroutine
pure subroutine s04(a) ! C1588
- !ERROR: An INTENT(OUT) dummy argument of a PURE procedure cannot have a polymorphic ultimate component
- class(polyAlloc), intent(out) :: a
+ !ERROR: An INTENT(OUT) dummy argument of a PURE subroutine may not have a polymorphic ultimate component
+ type(polyAlloc), intent(out) :: a
end subroutine
pure subroutine s05 ! C1589
- !ERROR: A PURE subprogram cannot have local variables with the SAVE attribute
+ !ERROR: A PURE subprogram may not have a variable with the SAVE attribute
real, save :: v1
- !ERROR: A PURE subprogram cannot have local variables with the SAVE attribute
+ !ERROR: A PURE subprogram may not have a variable with the SAVE attribute
real :: v2 = 0.
- !ERROR: A PURE subprogram cannot have local variables with the SAVE attribute
+ !TODO: once we have DATA: !ERROR: A PURE subprogram may not have a variable with the SAVE attribute
real :: v3
data v3/0./
- !ERROR: A PURE subprogram cannot have local variables with the SAVE attribute
+ !ERROR: A PURE subprogram may not have a variable with the SAVE attribute
real :: v4
common /blk/ v4
+ save /blk/
block
- !ERROR: A PURE subprogram cannot have local variables with the SAVE attribute
+ !ERROR: A PURE subprogram may not have a variable with the SAVE attribute
real, save :: v5
- !ERROR: A PURE subprogram cannot have local variables with the SAVE attribute
+ !ERROR: A PURE subprogram may not have a variable with the SAVE attribute
real :: v6 = 0.
- !ERROR: A PURE subprogram cannot have local variables with the SAVE attribute
end block
end subroutine
pure subroutine s06 ! C1589
- !ERROR: A PURE subprogram cannot have local variables with the VOLATILE attribute
+ !ERROR: A PURE subprogram may not have a variable with the VOLATILE attribute
real, volatile :: v1
block
- !ERROR: A PURE subprogram cannot have local variables with the VOLATILE attribute
+ !ERROR: A PURE subprogram may not have a variable with the VOLATILE attribute
real, volatile :: v2
end block
end subroutine
+ !ERROR: A dummy procedure of a PURE subprogram must be PURE
pure subroutine s07(p) ! C1590
- !ERROR: A dummy procedure of a PURE subprogram must be PURE
procedure(impure) :: p
end subroutine
! C1591 is tested in call11.f90.
impure subroutine impure2
end subroutine
end subroutine
- function volptr
- real, pointer, volatile :: volptr
- volptr => volatile
- end function
pure subroutine s09 ! C1593
real :: x
- !ERROR: A VOLATILE variable may not appear in a PURE subprogram
+ !ERROR: VOLATILE variable 'volatile' may not be referenced in PURE subprogram 's09'
x = volatile
- !ERROR: A VOLATILE variable may not appear in a PURE subprogram
- x = volptr
end subroutine
! C1594 is tested in call12.f90.
pure subroutine s10 ! C1595
integer :: n
- !ERROR: Any procedure referenced in a PURE subprogram must also be PURE
+ !ERROR: Procedure referenced in PURE subprogram 's10' must be PURE too
n = notpure(1)
end subroutine
pure subroutine s11(to) ! C1596
- type(polyAlloc) :: auto, to
- !ERROR: Deallocation of a polymorphic object is not permitted in a PURE subprogram
+ ! Implicit deallocation at the end of the subroutine
+ !ERROR: Deallocation of polymorphic object 'auto%a' is not permitted in a PURE subprogram
+ type(polyAlloc) :: auto
+ type(polyAlloc), intent(in out) :: to
+ !ERROR: Deallocation of polymorphic component '%a' is not permitted in a PURE subprogram
to = auto
- ! Implicit deallocation at the end of the subroutine:
- !ERROR: Deallocation of a polymorphic object is not permitted in a PURE subprogram
end subroutine
pure subroutine s12
character(20) :: buff
write(*, *) ! C1598
end subroutine
pure subroutine s13
- !ERROR: An image control statement is not allowed in a PURE subprogram
+ !ERROR: An image control statement may not appear in a PURE subprogram
sync all ! C1599
! TODO others from 11.6.1 (many)
end subroutine
interface
integer function foo()
end function
- real function realfunc(x)
+ pure real function realfunc(x)
real, intent(in) :: x
end function
pure integer function hasProcArg(p)
end type
contains
pure integer function f1(i)
+ value :: i
f1 = i
end
end
! end type
!contains
! pure function f1(i)
-! integer(4)::i
+! integer(4),value::i
! integer(4)::f1
! end
!end
!ERROR: No explicit type declared for 'z2'
z2 = 2.
contains
+ !ERROR: An internal subprogram may not contain an internal subprogram
subroutine sss1
implicit none
!ERROR: No explicit type declared for 'a3'
real, protected :: x
real :: y
interface s
- subroutine s1(x)
+ pure subroutine s1(x)
real, intent(out) :: x
end
subroutine s2(x, y)
contains
- pure real function pf1(dummy1, dummy2, dummy3, dummy4)
+ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
real, target :: local1
type(t1(0)) :: x1
type(t2(0)) :: x2
real, intent(inout), target :: dummy4[*]
real, target :: commonvar1
common /cblock/ commonvar1
- pf1 = 0.
x1 = t1(0)(local1)
!ERROR: Externally visible object 'usedfrom1' must not be associated with pointer component 'pt1' in a PURE procedure
x1 = t1(0)(usedfrom1)
!ERROR: Externally visible object 'modulevar4' must not be associated with pointer component 'ptop' in a PURE procedure
x4 = t4(0)(modulevar4)
contains
- subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
+ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
real, target :: local1a
type(t1(0)) :: x1a
type(t2(0)) :: x2a
x1a = t1(0)(usedfrom1)
!ERROR: Externally visible object 'modulevar1' must not be associated with pointer component 'pt1' in a PURE procedure
x1a = t1(0)(modulevar1)
- !ERROR: Externally visible object 'cblock' must not be associated with pointer component 'pt1' in a PURE procedure
+ !ERROR: Externally visible object 'commonvar1' must not be associated with pointer component 'pt1' in a PURE procedure
x1a = t1(0)(commonvar1)
!ERROR: Externally visible object 'dummy1' must not be associated with pointer component 'pt1' in a PURE procedure
x1a = t1(0)(dummy1)
!ERROR: Externally visible object 'modulevar4' must not be associated with pointer component 'ptop' in a PURE procedure
x4a = t4(0)(modulevar4)
end subroutine subr
- end function pf1
+ end subroutine
impure real function ipf1(dummy1, dummy2, dummy3, dummy4)
real, target :: local1
contains
- pure real function pf1(dummy1, dummy2, dummy3, dummy4)
+ pure subroutine ps1(dummy1, dummy2, dummy3, dummy4)
real, target :: local1
type(t1) :: x1
type(t2) :: x2
real, intent(inout), target :: dummy4[*]
real, target :: commonvar1
common /cblock/ commonvar1
- pf1 = 0.
x1 = t1(local1)
!ERROR: Externally visible object 'usedfrom1' must not be associated with pointer component 'pt1' in a PURE procedure
x1 = t1(usedfrom1)
!ERROR: Externally visible object 'modulevar4' must not be associated with pointer component 'ptop' in a PURE procedure
x4 = t4(modulevar4)
contains
- subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
+ pure subroutine subr(dummy1a, dummy2a, dummy3a, dummy4a)
real, target :: local1a
type(t1) :: x1a
type(t2) :: x2a
x1a = t1(usedfrom1)
!ERROR: Externally visible object 'modulevar1' must not be associated with pointer component 'pt1' in a PURE procedure
x1a = t1(modulevar1)
- !ERROR: Externally visible object 'cblock' must not be associated with pointer component 'pt1' in a PURE procedure
+ !ERROR: Externally visible object 'commonvar1' must not be associated with pointer component 'pt1' in a PURE procedure
x1a = t1(commonvar1)
!ERROR: Externally visible object 'dummy1' must not be associated with pointer component 'pt1' in a PURE procedure
x1a = t1(dummy1)
!ERROR: Externally visible object 'modulevar4' must not be associated with pointer component 'ptop' in a PURE procedure
x4a = t4(modulevar4)
end subroutine subr
- end function pf1
+ end subroutine
impure real function ipf1(dummy1, dummy2, dummy3, dummy4)
real, target :: local1
projects / platform / upstream / llvm.git / commitdiff