maxjhandsome
/
llvm-project
forked from OSchip/llvm-project
1
0
Fork 0
Code Issues Pull Requests Packages Releases Wiki Activity

[flang] Semantic checks for PURE subprograms (test call10.f90) 

Fix bug found in testing

Original-commit: flang-compiler/f18@ccdd7326ba
Reviewed-on: https://github.com/flang-compiler/f18/pull/825
This commit is contained in:
peter klausler 2019-11-12 15:43:09 -08:00
parent 0f6eaa6269
commit ed1ed24ec2
28 changed files with 513 additions and 179 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
flang/lib/evaluate/intrinsics.cc
View File

@ -1476,6 +1476,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
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{

16
flang/lib/evaluate/tools.cc
View File

@ -739,22 +739,30 @@ bool HasVectorSubscript(const Expr<SomeType> &expr) {
}
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;
}
}

5
flang/lib/evaluate/tools.h
View File

@ -810,10 +810,11 @@ bool HasVectorSubscript(const Expr<SomeType> &);
// 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);
}
}

1
flang/lib/semantics/CMakeLists.txt
View File

@ -28,6 +28,7 @@ add_library(FortranSemantics
check-io.cc
check-nullify.cc
check-omp-structure.cc
check-purity.cc
check-return.cc
check-stop.cc
expression.cc

110
flang/lib/semantics/assignment.cc
View File

@ -300,16 +300,16 @@ struct WhereContext {
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 &);
@ -337,27 +337,57 @@ private:
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 &) {
@ -410,7 +440,7 @@ void AssignmentContext::Analyze(const parser::ForallStmt &stmt) {
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);
}
@ -494,7 +524,7 @@ int AssignmentContext::GetIntegerKind(
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);
}
}
@ -511,71 +541,51 @@ MaskExpr AssignmentContext::GetMask(
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>;

4
flang/lib/semantics/assignment.h
View File

@ -59,6 +59,9 @@ class AssignmentChecker : public virtual BaseChecker {
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 &);
@ -68,6 +71,7 @@ public:
private:
common::Indirection<AssignmentContext> context_;
parser::CharBlock at_;
};
// Semantic analysis of an assignment statement or WHERE/FORALL construct.

25
flang/lib/semantics/check-call.cc
View File

@ -183,40 +183,33 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
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());
}
}
}

5
flang/lib/semantics/check-call.h
View File

@ -41,12 +41,13 @@ void CheckArguments(const evaluate::characteristics::Procedure &,
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 &);
}

112
flang/lib/semantics/check-declarations.cc
View File

@ -22,6 +22,7 @@
#include "type.h"
#include "../evaluate/check-expression.h"
#include "../evaluate/fold.h"
#include "../evaluate/tools.h"
namespace Fortran::semantics {
@ -57,8 +58,9 @@ private:
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) {
@ -94,10 +96,7 @@ void CheckHelper::Check(const Symbol &symbol) {
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>()};
@ -107,6 +106,35 @@ void CheckHelper::Check(const Symbol &symbol) {
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) ||
@ -119,6 +147,23 @@ void CheckHelper::Check(const Symbol &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)) {
@ -160,16 +205,45 @@ void CheckHelper::Check(const Symbol &symbol) {
}
}
}
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>()}) {
@ -230,7 +304,8 @@ void CheckHelper::CheckValue(
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);
}
@ -268,8 +343,9 @@ void CheckHelper::CheckVolatile(const Symbol &symbol, bool isAssociated,
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);
}

26
flang/lib/semantics/check-io.cc
View File

@ -429,24 +429,28 @@ void IoChecker::Enter(const parser::StatVariable &) {
}
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;
@ -454,6 +458,7 @@ void IoChecker::Leave(const parser::FlushStmt &) {
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),
@ -465,6 +470,7 @@ void IoChecker::Leave(const parser::InquireStmt &stmt) {
}
void IoChecker::Leave(const parser::OpenStmt &) {
CheckForPureSubprogram();
CheckForRequiredSpecifier(specifierSet_.test(IoSpecKind::Unit) ||
specifierSet_.test(IoSpecKind::Newunit),
"UNIT or NEWUNIT"); // C1204, C1205
@ -496,9 +502,15 @@ void IoChecker::Leave(const parser::OpenStmt &) {
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;
}
@ -519,16 +531,21 @@ void IoChecker::Leave(const parser::ReadStmt &) {
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
@ -706,4 +723,11 @@ void IoChecker::CheckForProhibitedSpecifier(
}
}
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

2
flang/lib/semantics/check-io.h
View File

@ -134,6 +134,8 @@ private:
flags_.reset();
}
void CheckForPureSubprogram() const;
SemanticsContext &context_;
IoStmtKind stmt_ = IoStmtKind::None;
common::EnumSet<IoSpecKind, common::IoSpecKind_enumSize> specifierSet_;

79
flang/lib/semantics/check-purity.cc Normal file
View File

@ -0,0 +1,79 @@
// 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;
}
}
}

45
flang/lib/semantics/check-purity.h Normal file
View File

@ -0,0 +1,45 @@
// 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

19
flang/lib/semantics/expression.cc
View File

@ -675,6 +675,16 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
// 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});
}
}
@ -1801,6 +1811,15 @@ std::optional<characteristics::Procedure> ExpressionAnalyzer::CheckCall(
}
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;
}

2
flang/lib/semantics/expression.h
View File

@ -370,7 +370,7 @@ void ConformabilityCheck(
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) {

3
flang/lib/semantics/semantics.cc
View File

@ -26,6 +26,7 @@
#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"
@ -117,7 +118,7 @@ using StatementSemanticsPass1 = ExprChecker;
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) {

2
flang/lib/semantics/symbol.h
View File

@ -314,7 +314,7 @@ private:
MaybeExpr bindName_;
};
class FinalProcDetails {};
class FinalProcDetails {}; // TODO
class MiscDetails {
public:

107
flang/lib/semantics/tools.cc
View File

@ -211,6 +211,7 @@ bool IsProcedure(const Symbol &symbol) {
[](const GenericDetails &) { return true; },
[](const ProcBindingDetails &) { return true; },
[](const UseDetails &x) { return IsProcedure(x.symbol()); },
// TODO: FinalProcDetails?
[](const auto &) { return false; },
},
symbol.details());
@ -443,11 +444,21 @@ bool IsSaved(const Symbol &symbol) {
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;
}
}
@ -472,19 +483,27 @@ bool CanBeTypeBoundProc(const Symbol *symbol) {
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) {
@ -503,15 +522,17 @@ bool IsAssumedLengthCharacterFunction(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 &currentScope) {
@ -566,22 +587,20 @@ std::unique_ptr<parser::Message> WhyNotModifiable(parser::CharBlock at,
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) {
@ -626,6 +645,12 @@ struct ImageControlStmtHelper {
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) {
@ -662,7 +687,7 @@ std::optional<parser::MessageFixedText> GetImageControlStmtCoarrayMsg(
return std::nullopt;
}
const parser::CharBlock GetImageControlStmtLocation(
parser::CharBlock GetImageControlStmtLocation(
const parser::ExecutableConstruct &executableConstruct) {
return std::visit(
common::visitors{
@ -698,6 +723,17 @@ bool HasCoarray(const parser::Expr &expression) {
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()};
@ -996,6 +1032,8 @@ ComponentIterator<componentKind>::const_iterator::PlanComponentTraversal(
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()};
@ -1060,6 +1098,11 @@ void ComponentIterator<componentKind>::const_iterator::Increment() {
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++)};
@ -1093,19 +1136,18 @@ template class ComponentIterator<ComponentKind::Ordered>;
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(
@ -1121,6 +1163,19 @@ 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};

42
flang/lib/semantics/tools.h
View File

@ -123,6 +123,8 @@ inline bool IsProtected(const Symbol &symbol) {
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>()};
@ -135,17 +137,18 @@ std::optional<parser::MessageFixedText> WhyNotModifiable(
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 &);
@ -292,14 +295,14 @@ template<typename T> std::optional<std::int64_t> GetIntValue(const T &x) {
//
// 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:
@ -350,16 +353,25 @@ 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; }
@ -408,10 +420,12 @@ extern template class ComponentIterator<ComponentKind::Ordered>;
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,
@ -425,6 +439,10 @@ UltimateComponentIterator::const_iterator FindCoarrayUltimateComponent(
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_

1
flang/test/semantics/CMakeLists.txt
View File

@ -183,6 +183,7 @@ set(ERROR_TESTS
call07.f90
call08.f90
call09.f90
call10.f90
call13.f90
call14.f90
misc-declarations.f90

2
flang/test/semantics/call02.f90
View File

@ -74,7 +74,7 @@ module m02
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

57
flang/test/semantics/call10.f90
View File

@ -61,18 +61,18 @@ module m
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
@ -84,46 +84,46 @@ module m
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.
@ -138,29 +138,24 @@ module m
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
@ -195,7 +190,7 @@ module m
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

2
flang/test/semantics/expr-errors02.f90
View File

@ -22,7 +22,7 @@ module m
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)

3
flang/test/semantics/modfile03.f90
View File

@ -61,6 +61,7 @@ module m5a
end type
contains
pure integer function f1(i)
value :: i
f1 = i
end
end
@ -73,7 +74,7 @@ end
! end type
!contains
! pure function f1(i)
! integer(4)::i
! integer(4),value::i
! integer(4)::f1
! end
!end

1
flang/test/semantics/resolve04.f90
View File

@ -56,6 +56,7 @@ contains
!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'

2
flang/test/semantics/resolve62.f90
View File

@ -65,7 +65,7 @@ module m4
real, protected :: x
real :: y
interface s
subroutine s1(x)
pure subroutine s1(x)
real, intent(out) :: x
end
subroutine s2(x, y)

9
flang/test/semantics/structconst03.f90
View File

@ -62,7 +62,7 @@ module module1
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
@ -74,7 +74,6 @@ module module1
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)
@ -98,7 +97,7 @@ module module1
!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
@ -113,7 +112,7 @@ module module1
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)
@ -135,7 +134,7 @@ module module1
!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

9
flang/test/semantics/structconst04.f90
View File

@ -57,7 +57,7 @@ module module1
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
@ -69,7 +69,6 @@ module module1
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)
@ -93,7 +92,7 @@ module module1
!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
@ -108,7 +107,7 @@ module module1
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)
@ -130,7 +129,7 @@ module module1
!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