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

[flang] For call11.f90: more checks on PURE subprograms and TBP bindings 

Original-commit: flang-compiler/f18@7aa47f0b9e
Reviewed-on: https://github.com/flang-compiler/f18/pull/833
This commit is contained in:
peter klausler 2019-11-15 14:26:10 -08:00
parent 841561b432
commit ff765f8500
22 changed files with 514 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
flang/lib/evaluate/characteristics.cc
View File

@ -50,16 +50,12 @@ static bool ShapesAreCompatible(const Shape &x, const Shape &y) {
auto yIter{y.begin()};
for (const auto &xDim : x) {
const auto &yDim{*yIter++};
if (xDim.has_value() != yDim.has_value()) {
return false;
}
if (xDim) {
auto xConst{ToInt64(*xDim)};
auto yConst{ToInt64(*yDim)};
if (xConst.has_value() != yConst.has_value() ||
(xConst && *xConst != *yConst)) {
if (!yDim || ToInt64(*xDim) != ToInt64(*yDim)) {
return false;
}
} else if (yDim) {
return false;
}
}
return true;
@ -561,8 +557,33 @@ Procedure::Procedure(DummyArguments &&args, Attrs a)
Procedure::~Procedure() {}
bool Procedure::operator==(const Procedure &that) const {
return attrs == that.attrs && dummyArguments == that.dummyArguments &&
functionResult == that.functionResult;
return attrs == that.attrs && functionResult == that.functionResult &&
dummyArguments == that.dummyArguments;
}
bool Procedure::CanOverride(
const Procedure &that, std::optional<int> passIndex) const {
// A PURE procedure may override an impure one (7.5.7.3(2))
if ((that.attrs.test(Attr::Pure) && !attrs.test(Attr::Pure)) ||
that.attrs.test(Attr::Elemental) != attrs.test(Attr::Elemental) ||
functionResult != that.functionResult) {
return false;
}
if (passIndex) {
int argCount{static_cast<int>(dummyArguments.size())};
if (argCount != static_cast<int>(that.dummyArguments.size())) {
return false;
}
CHECK(*passIndex >= 0 && *passIndex <= argCount);
for (int j{0}; j < argCount; ++j) {
if (j != *passIndex && dummyArguments[j] != that.dummyArguments[j]) {
return false;
}
}
return true;
} else {
return dummyArguments == that.dummyArguments;
}
}
std::optional<Procedure> Procedure::Characterize(

1
flang/lib/evaluate/characteristics.h
View File

@ -261,6 +261,7 @@ struct Procedure {
return !attrs.test(Attr::ImplicitInterface);
}
bool CanBeCalledViaImplicitInterface() const;
bool CanOverride(const Procedure &, std::optional<int> passIndex) const;
std::ostream &Dump(std::ostream &) const;
std::optional<FunctionResult> functionResult;

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

@ -765,4 +765,33 @@ parser::Message *AttachDeclaration(
}
return message;
}
class FindImpureCallHelper
: public AnyTraverse<FindImpureCallHelper, std::optional<std::string>> {
using Result = std::optional<std::string>;
using Base = AnyTraverse<FindImpureCallHelper, Result>;
public:
explicit FindImpureCallHelper(const IntrinsicProcTable &intrinsics)
: Base{*this}, intrinsics_{intrinsics} {}
using Base::operator();
Result operator()(const ProcedureRef &call) const {
if (auto chars{characteristics::Procedure::Characterize(
call.proc(), intrinsics_)}) {
if (chars->attrs.test(characteristics::Procedure::Attr::Pure)) {
return std::nullopt;
}
}
return call.proc().GetName();
}
private:
const IntrinsicProcTable &intrinsics_;
};
std::optional<std::string> FindImpureCall(
const IntrinsicProcTable &intrinsics, const Expr<SomeType> &expr) {
return FindImpureCallHelper{intrinsics}(expr);
}
}

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

@ -817,5 +817,10 @@ parser::Message *SayWithDeclaration(
MESSAGES &messages, const Symbol *symbol, A &&... x) {
return AttachDeclaration(messages.Say(std::forward<A>(x)...), symbol);
}
// Check for references to impure procedures; returns the name
// of one to complain about, if any exist.
std::optional<std::string> FindImpureCall(
const IntrinsicProcTable &, const Expr<SomeType> &);
}
#endif // FORTRAN_EVALUATE_TOOLS_H_

6
flang/lib/evaluate/variable.cc
View File

@ -606,10 +606,10 @@ bool Component::operator==(const Component &that) const {
return base_ == that.base_ && &*symbol_ == &*that.symbol_;
}
bool NamedEntity::operator==(const NamedEntity &that) const {
if (&GetLastSymbol() != &that.GetLastSymbol()) {
return false;
if (IsSymbol()) {
return that.IsSymbol() && GetLastSymbol() == that.GetLastSymbol();
} else {
return UnwrapComponent() == that.UnwrapComponent();
return !that.IsSymbol() && GetComponent() == that.GetComponent();
}
}
template<int KIND>

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

@ -259,7 +259,7 @@ using MaskExpr = evaluate::Expr<evaluate::LogicalResult>;
// and some number of active WHERE statements/constructs. WHERE can nest
// in FORALL but not vice versa. Pointer assignments are allowed in
// FORALL but not in WHERE. These constraints are manifest in the grammar
// and don't need to be rechecked here, since they cannot appear in the
// and don't need to be rechecked here, since errors cannot appear in the
// parse tree.
struct Control {
Symbol *name;
@ -289,8 +289,8 @@ struct ForallContext {
};
struct WhereContext {
explicit WhereContext(MaskExpr &&x) : thisMaskExpr{std::move(x)} {}
WhereContext(MaskExpr &&x, const WhereContext *o, const ForallContext *f)
: outer{o}, forall{f}, thisMaskExpr{std::move(x)} {}
const WhereContext *outer{nullptr};
const ForallContext *forall{nullptr}; // innermost enclosing FORALL
std::optional<parser::CharBlock> constructName;
@ -308,7 +308,10 @@ public:
bool operator==(const AssignmentContext &x) const { return this == &x; }
void set_at(parser::CharBlock at) { at_ = at; }
void set_at(parser::CharBlock at) {
at_ = at;
context_.set_location(at_);
}
void Analyze(const parser::AssignmentStmt &);
void Analyze(const parser::PointerAssignmentStmt &);
@ -319,10 +322,8 @@ public:
void Analyze(const parser::ConcurrentHeader &);
template<typename A> void Analyze(const parser::Statement<A> &stmt) {
std::optional<parser::CharBlock> saveLocation{context_.location()};
context_.set_location(stmt.source);
set_at(stmt.source);
Analyze(stmt.statement);
context_.set_location(saveLocation);
}
template<typename A> void Analyze(const common::Indirection<A> &x) {
Analyze(x.value());
@ -339,12 +340,15 @@ private:
const Symbol *FindPureProcedureContaining(parser::CharBlock) const;
int GetIntegerKind(const std::optional<parser::IntegerTypeSpec> &);
void CheckForImpureCall(const evaluate::Expr<evaluate::SomeType> &);
void CheckForImpureCall(
const std::optional<evaluate::Expr<evaluate::SomeType>> &);
MaskExpr GetMask(const parser::LogicalExpr &, bool defaultValue = true) const;
MaskExpr GetMask(const parser::LogicalExpr &, bool defaultValue = true);
template<typename... A>
parser::Message *Say(parser::CharBlock at, A &&... args) {
return &context_.messages().Say(at, std::forward<A>(args)...);
return &context_.Say(at, std::forward<A>(args)...);
}
SemanticsContext &context_;
@ -354,6 +358,13 @@ private:
};
void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
const auto &lhs{std::get<parser::Variable>(stmt.t)};
const auto &rhs{std::get<parser::Expr>(stmt.t)};
auto lhsExpr{AnalyzeExpr(context_, lhs)};
auto rhsExpr{AnalyzeExpr(context_, rhs)};
CheckForImpureCall(lhsExpr);
CheckForImpureCall(rhsExpr);
// TODO: preserve analyzed typed expressions
if (forall_) {
// TODO: Warn if some name in forall_->activeNames or its outer
// contexts does not appear on LHS
@ -363,26 +374,19 @@ void AssignmentContext::Analyze(const parser::AssignmentStmt &stmt) {
// 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 (lhsExpr) {
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->IsPolymorphic() && FindPureProcedureContaining(rhs.source)) {
Say(at_,
"Deallocation of polymorphic object is not permitted in a PURE subprogram"_err_en_US);
}
if (type->category() == TypeCategory::Derived &&
!type->IsUnlimitedPolymorphic() /* TODO */ &&
!type->IsUnlimitedPolymorphic() &&
FindPureProcedureContaining(rhs.source)) {
if (auto bad{FindPolymorphicAllocatableUltimateComponent(
if (auto bad{FindPolymorphicAllocatableNonCoarrayUltimateComponent(
type->GetDerivedTypeSpec())}) {
evaluate::SayWithDeclaration(context_.messages(), &*bad, at_,
"Deallocation of polymorphic component '%s' is not permitted in a PURE subprogram"_err_en_US,
"Deallocation of polymorphic non-coarray component '%s' is not permitted in a PURE subprogram"_err_en_US,
bad.BuildResultDesignatorName());
}
}
@ -400,7 +404,8 @@ void AssignmentContext::Analyze(const parser::PointerAssignmentStmt &) {
}
void AssignmentContext::Analyze(const parser::WhereStmt &stmt) {
WhereContext where{GetMask(std::get<parser::LogicalExpr>(stmt.t))};
WhereContext where{
GetMask(std::get<parser::LogicalExpr>(stmt.t)), where_, forall_};
AssignmentContext nested{*this, where};
nested.Analyze(std::get<parser::AssignmentStmt>(stmt.t));
}
@ -410,7 +415,8 @@ void AssignmentContext::Analyze(const parser::WhereConstruct &construct) {
const auto &whereStmt{
std::get<parser::Statement<parser::WhereConstructStmt>>(construct.t)};
WhereContext where{
GetMask(std::get<parser::LogicalExpr>(whereStmt.statement.t))};
GetMask(std::get<parser::LogicalExpr>(whereStmt.statement.t)), where_,
forall_};
if (const auto &name{
std::get<std::optional<parser::Name>>(whereStmt.statement.t)}) {
where.constructName = name->source;
@ -452,7 +458,7 @@ void AssignmentContext::Analyze(const parser::ForallConstruct &construct) {
AssignmentContext nested{*this, forall};
const auto &forallStmt{
std::get<parser::Statement<parser::ForallConstructStmt>>(construct.t)};
context_.set_location(forallStmt.source);
nested.set_at(forallStmt.source);
nested.Analyze(std::get<common::Indirection<parser::ConcurrentHeader>>(
forallStmt.statement.t));
for (const auto &body :
@ -466,7 +472,7 @@ void AssignmentContext::Analyze(
CHECK(where_);
const auto &elsewhereStmt{
std::get<parser::Statement<parser::MaskedElsewhereStmt>>(elsewhere.t)};
context_.set_location(elsewhereStmt.source);
set_at(elsewhereStmt.source);
MaskExpr mask{
GetMask(std::get<parser::LogicalExpr>(elsewhereStmt.statement.t))};
MaskExpr copyCumulative{where_->cumulativeMaskExpr};
@ -513,6 +519,15 @@ void AssignmentContext::Analyze(const parser::ConcurrentHeader &header) {
const parser::Name &name{std::get<parser::Name>(control.t)};
bool inserted{forall_->activeNames.insert(name.source).second};
CHECK(inserted || context_.HasError(name));
CheckForImpureCall(AnalyzeExpr(context_, std::get<1>(control.t)));
CheckForImpureCall(AnalyzeExpr(context_, std::get<2>(control.t)));
if (const auto &stride{std::get<3>(control.t)}) {
CheckForImpureCall(AnalyzeExpr(context_, *stride));
}
}
if (const auto &mask{
std::get<std::optional<parser::ScalarLogicalExpr>>(header.t)}) {
CheckForImpureCall(AnalyzeExpr(context_, *mask));
}
}
@ -529,10 +544,30 @@ int AssignmentContext::GetIntegerKind(
}
}
void AssignmentContext::CheckForImpureCall(
const evaluate::Expr<evaluate::SomeType> &expr) {
if (forall_) {
const auto &intrinsics{context_.foldingContext().intrinsics()};
if (auto bad{FindImpureCall(intrinsics, expr)}) {
Say(at_,
"Impure procedure '%s' may not be referenced in a FORALL"_err_en_US,
*bad);
}
}
}
void AssignmentContext::CheckForImpureCall(
const std::optional<evaluate::Expr<evaluate::SomeType>> &maybeExpr) {
if (maybeExpr) {
CheckForImpureCall(*maybeExpr);
}
}
MaskExpr AssignmentContext::GetMask(
const parser::LogicalExpr &expr, bool defaultValue) const {
const parser::LogicalExpr &expr, bool defaultValue) {
MaskExpr mask{defaultValue};
if (auto maybeExpr{AnalyzeExpr(context_, expr)}) {
CheckForImpureCall(*maybeExpr);
auto *logical{
std::get_if<evaluate::Expr<evaluate::SomeLogical>>(&maybeExpr->u)};
CHECK(logical);

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

@ -53,6 +53,7 @@ private:
void CheckValue(const Symbol &, const DerivedTypeSpec *);
void CheckVolatile(
const Symbol &, bool isAssociated, const DerivedTypeSpec *);
void CheckBinding(const Symbol &);
SemanticsContext &context_;
evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
@ -84,8 +85,8 @@ void CheckHelper::Check(
const DeclTypeSpec &type, bool canHaveAssumedTypeParameters) {
if (type.category() == DeclTypeSpec::Character) {
Check(type.characterTypeSpec().length(), canHaveAssumedTypeParameters);
} else if (const DerivedTypeSpec * spec{type.AsDerived()}) {
for (auto &parm : spec->parameters()) {
} else if (const DerivedTypeSpec * derived{type.AsDerived()}) {
for (auto &parm : derived->parameters()) {
Check(parm.second, canHaveAssumedTypeParameters);
}
}
@ -106,6 +107,40 @@ void CheckHelper::Check(const Symbol &symbol) {
if (isAssociated) {
return; // only care about checking VOLATILE on associated symbols
}
if (symbol.has<ProcBindingDetails>()) {
CheckBinding(symbol);
return;
}
if (const auto *details{symbol.detailsIf<DerivedTypeDetails>()}) {
CHECK(symbol.scope());
CHECK(symbol.scope()->symbol() == &symbol);
CHECK(symbol.scope()->IsDerivedType());
if (symbol.attrs().test(Attr::ABSTRACT) &&
(symbol.attrs().test(Attr::BIND_C) ||
(details && details->sequence()))) {
messages_.Say("An ABSTRACT derived type must be extensible"_err_en_US);
}
if (const DeclTypeSpec * parent{FindParentTypeSpec(symbol)}) {
const DerivedTypeSpec *parentDerived{parent->AsDerived()};
if (!IsExtensibleType(parentDerived)) {
messages_.Say("The parent type is not extensible"_err_en_US);
}
if (!symbol.attrs().test(Attr::ABSTRACT) && parentDerived &&
parentDerived->typeSymbol().attrs().test(Attr::ABSTRACT)) {
ScopeComponentIterator components{*parentDerived};
for (const Symbol &component : components) {
if (component.attrs().test(Attr::DEFERRED)) {
if (symbol.scope()->FindComponent(component.name()) == &component) {
evaluate::SayWithDeclaration(messages_, &component,
"Non-ABSTRACT extension of ABSTRACT derived type '%s' lacks a binding for DEFERRED procedure '%s'"_err_en_US,
parentDerived->typeSymbol().name(), component.name());
}
}
}
}
}
return;
}
bool inPure{innermostSymbol_ && IsPureProcedure(*innermostSymbol_)};
if (inPure) {
if (IsSaved(symbol)) {
@ -341,10 +376,93 @@ void CheckHelper::CheckVolatile(const Symbol &symbol, bool isAssociated,
}
}
void CheckHelper::CheckBinding(const Symbol &symbol) {
const Scope &dtScope{symbol.owner()};
const auto &binding{symbol.get<ProcBindingDetails>()};
CHECK(dtScope.kind() == Scope::Kind::DerivedType);
if (const Symbol * dtSymbol{dtScope.symbol()}) {
if (symbol.attrs().test(Attr::DEFERRED)) {
if (!dtSymbol->attrs().test(Attr::ABSTRACT)) {
evaluate::SayWithDeclaration(messages_, dtSymbol,
"Procedure bound to non-ABSTRACT derived type '%s' may not be DEFERRED"_err_en_US,
dtSymbol->name());
}
if (symbol.attrs().test(Attr::NON_OVERRIDABLE)) {
messages_.Say(
"Type-bound procedure '%s' may not be both DEFERRED and NON_OVERRIDABLE"_err_en_US,
symbol.name());
}
}
}
if (const Symbol * overridden{FindOverriddenBinding(symbol)}) {
if (overridden->attrs().test(Attr::NON_OVERRIDABLE)) {
evaluate::SayWithDeclaration(messages_, overridden,
"Override of NON_OVERRIDABLE '%s' is not permitted"_err_en_US,
symbol.name());
}
if (const auto *overriddenBinding{
overridden->detailsIf<ProcBindingDetails>()}) {
if (!binding.symbol().attrs().test(Attr::PURE) &&
overriddenBinding->symbol().attrs().test(Attr::PURE)) {
evaluate::SayWithDeclaration(messages_, overridden,
"An overridden PURE type-bound procedure binding must also be PURE"_err_en_US);
return;
}
if (!binding.symbol().attrs().test(Attr::ELEMENTAL) &&
overriddenBinding->symbol().attrs().test(Attr::ELEMENTAL)) {
evaluate::SayWithDeclaration(messages_, overridden,
"A type-bound procedure and its override must both, or neither, be ELEMENTAL"_err_en_US);
return;
}
auto bindingChars{evaluate::characteristics::Procedure::Characterize(
binding.symbol(), context_.intrinsics())};
auto overriddenChars{evaluate::characteristics::Procedure::Characterize(
overriddenBinding->symbol(), context_.intrinsics())};
if (binding.passIndex()) {
if (overriddenBinding->passIndex()) {
int passIndex{*binding.passIndex()};
if (passIndex == *overriddenBinding->passIndex()) {
if (!(bindingChars && overriddenChars &&
bindingChars->CanOverride(*overriddenChars, passIndex))) {
evaluate::SayWithDeclaration(messages_, overridden,
"A type-bound procedure and its override must have compatible interfaces apart from their passed argument"_err_en_US);
}
} else {
evaluate::SayWithDeclaration(messages_, overridden,
"A type-bound procedure and its override must use the same PASS argument"_err_en_US);
}
} else {
evaluate::SayWithDeclaration(messages_, overridden,
"A passed-argument type-bound procedure may not override a NOPASS procedure"_err_en_US);
}
} else if (overriddenBinding->passIndex()) {
evaluate::SayWithDeclaration(messages_, overridden,
"A NOPASS type-bound procedure may not override a passed-argument procedure"_err_en_US);
} else if (!(bindingChars && overriddenChars &&
bindingChars->CanOverride(
*overriddenChars, std::nullopt))) {
evaluate::SayWithDeclaration(messages_, overridden,
"A type-bound procedure and its override must have compatible interfaces"_err_en_US);
}
if (symbol.attrs().test(Attr::PRIVATE) &&
overridden->attrs().test(Attr::PUBLIC)) {
evaluate::SayWithDeclaration(messages_, overridden,
"A PRIVATE procedure may not override a PUBLIC procedure"_err_en_US);
}
} else {
evaluate::SayWithDeclaration(messages_, overridden,
"A type-bound procedure binding may not have the same name as a parent component"_err_en_US);
}
}
}
void CheckHelper::Check(const Scope &scope) {
scope_ = &scope;
if (const Symbol * scopeSymbol{scope.symbol()}) {
innermostSymbol_ = scopeSymbol;
common::Restorer<const Symbol *> restorer{innermostSymbol_};
if (const Symbol * symbol{scope.symbol()}) {
innermostSymbol_ = symbol;
} else if (scope.IsDerivedType()) {
return; // PDT instantiations have null symbol()
}
for (const auto &pair : scope) {
Check(*pair.second);

32
flang/lib/semantics/resolve-names.cc
View File

@ -469,7 +469,6 @@ public:
Symbol *FindInScope(const Scope &, const parser::Name &);
Symbol *FindInScope(const Scope &, const SourceName &);
// Search for name in a derived type scope and its parents.
Symbol *FindInTypeOrParents(const Scope &, SourceName);
Symbol *FindInTypeOrParents(const Scope &, const parser::Name &);
Symbol *FindInTypeOrParents(const parser::Name &);
void EraseSymbol(const parser::Name &);
@ -1957,7 +1956,7 @@ Symbol *ScopeHandler::FindSymbol(const parser::Name &name) {
}
Symbol *ScopeHandler::FindSymbol(const Scope &scope, const parser::Name &name) {
if (scope.IsDerivedType()) {
if (Symbol * symbol{FindInTypeOrParents(scope, name.source)}) {
if (Symbol * symbol{scope.FindComponent(name.source)}) {
if (!symbol->has<ProcBindingDetails>() &&
!symbol->test(Symbol::Flag::ParentComp)) {
return Resolve(name, symbol);
@ -2005,20 +2004,9 @@ Symbol *ScopeHandler::FindInScope(const Scope &scope, const SourceName &name) {
}
// Find a component or type parameter by name in a derived type or its parents.
Symbol *ScopeHandler::FindInTypeOrParents(const Scope &scope, SourceName name) {
if (scope.IsDerivedType()) {
if (Symbol * symbol{FindInScope(scope, name)}) {
return symbol;
}
if (const Scope * parent{scope.GetDerivedTypeParent()}) {
return FindInTypeOrParents(*parent, name);
}
}
return nullptr;
}
Symbol *ScopeHandler::FindInTypeOrParents(
const Scope &scope, const parser::Name &name) {
return Resolve(name, FindInTypeOrParents(scope, name.source));
return Resolve(name, scope.FindComponent(name.source));
}
Symbol *ScopeHandler::FindInTypeOrParents(const parser::Name &name) {
return FindInTypeOrParents(currScope(), name);
@ -3608,7 +3596,7 @@ void DeclarationVisitor::Post(const parser::DerivedTypeStmt &x) {
derivedTypeInfo_.type = &symbol;
PushScope(Scope::Kind::DerivedType, &symbol);
if (extendsType) {
// Declare the "parent component"; private if the type is
// Declare the "parent component"; private if the type is.
// Any symbol stored in the EXTENDS() clause is temporarily
// hidden so that a new symbol can be created for the parent
// component without producing spurious errors about already
@ -3812,6 +3800,9 @@ void DeclarationVisitor::Post(
}
if (auto *s{MakeTypeSymbol(bindingName, ProcBindingDetails{*procedure})}) {
SetPassNameOn(*s);
if (GetAttrs().test(Attr::DEFERRED)) {
context().SetError(*s);
}
}
}
}
@ -3854,6 +3845,9 @@ void DeclarationVisitor::Post(
if (auto *s{
MakeTypeSymbol(bindingName, ProcBindingDetails{*interface})}) {
SetPassNameOn(*s);
if (!GetAttrs().test(Attr::DEFERRED)) {
context().SetError(*s);
}
}
}
}
@ -3882,7 +3876,7 @@ bool DeclarationVisitor::Pre(const parser::TypeBoundGenericStmt &x) {
// look in parent types:
Symbol *inheritedSymbol{nullptr};
for (const auto &name : info.GetAllNames(context())) {
inheritedSymbol = FindInTypeOrParents(currScope(), SourceName{name});
inheritedSymbol = currScope().FindComponent(SourceName{name});
if (inheritedSymbol) {
break;
}
@ -5297,7 +5291,7 @@ const parser::Name *DeclarationVisitor::FindComponent(
}
} else if (const DerivedTypeSpec * derived{type->AsDerived()}) {
if (const Scope * scope{derived->scope()}) {
if (Resolve(component, FindInTypeOrParents(*scope, component.source))) {
if (Resolve(component, scope->FindComponent(component.source))) {
if (CheckAccessibleComponent(component.source, *component.symbol)) {
return &component;
}
@ -6265,9 +6259,9 @@ void ResolveNamesVisitor::SetPassArg(
Say(name,
type->IsPolymorphic()
? "Passed-object dummy argument '%s' of procedure '%s'"
" must not be polymorphic because '%s' is not extensible"_err_en_US
" may not be polymorphic because '%s' is not extensible"_err_en_US
: "Passed-object dummy argument '%s' of procedure '%s'"
" must polymorphic because '%s' is extensible"_err_en_US,
" must be polymorphic because '%s' is extensible"_err_en_US,
passName.value(), name, typeSymbol.name());
return;
}

12
flang/lib/semantics/scope.cc
View File

@ -85,6 +85,18 @@ Symbol *Scope::FindSymbol(const SourceName &name) const {
}
}
Symbol *Scope::FindComponent(SourceName name) const {
CHECK(IsDerivedType());
auto found{find(name)};
if (found != end()) {
return &*found->second;
} else if (const Scope * parent{GetDerivedTypeParent()}) {
return parent->FindComponent(name);
} else {
return nullptr;
}
}
const std::list<EquivalenceSet> &Scope::equivalenceSets() const {
return equivalenceSets_;
}

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

@ -123,6 +123,10 @@ public:
// Look for symbol by name in this scope and host (depending on imports).
Symbol *FindSymbol(const SourceName &) const;
// Look for component symbol by name in a derived type's scope and
// parents'.
Symbol *FindComponent(SourceName) const;
/// Make a Symbol with unknown details.
std::pair<iterator, bool> try_emplace(
const SourceName &name, Attrs attrs = Attrs()) {

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

@ -556,7 +556,7 @@ const Symbol *Symbol::GetParentComponent(const Scope *scope) const {
CHECK(scope_);
scope = scope_;
}
return dtDetails->GetParentComponent(*scope);
return dtDetails->GetParentComponent(DEREF(scope));
} else {
return nullptr;
}

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

@ -582,8 +582,23 @@ public:
details_);
}
bool operator==(const Symbol &that) const { return this == &that; }
bool operator!=(const Symbol &that) const { return this != &that; }
// For the purposes of comparing type parameter expressions while
// testing the compatibility of procedure characteristics, two
// object dummy arguments with the same name are considered equal.
bool operator==(const Symbol &that) const {
if (this == &that) {
return true;
} else if (name() != that.name()) {
return false;
} else if (const auto *object{detailsIf<ObjectEntityDetails>()}) {
if (const auto *thatObject{that.detailsIf<ObjectEntityDetails>()}) {
return object->isDummy() && thatObject->isDummy();
}
}
return false;
}
bool operator!=(const Symbol &that) const { return !(*this == that); }
bool operator<(const Symbol &that) const {
// For sets of symbols: collate them by source location
return name_.begin() < that.name_.begin();

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

@ -362,6 +362,51 @@ const Symbol *FindFunctionResult(const Symbol &symbol) {
return nullptr;
}
const Symbol *FindOverriddenBinding(const Symbol &symbol) {
if (symbol.has<ProcBindingDetails>()) {
if (const DeclTypeSpec * parentType{FindParentTypeSpec(symbol.owner())}) {
if (const DerivedTypeSpec * parentDerived{parentType->AsDerived()}) {
if (const Scope * parentScope{parentDerived->typeSymbol().scope()}) {
return parentScope->FindComponent(symbol.name());
}
}
}
}
return nullptr;
}
const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &derived) {
return FindParentTypeSpec(derived.typeSymbol());
}
const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &decl) {
if (const DerivedTypeSpec * derived{decl.AsDerived()}) {
return FindParentTypeSpec(*derived);
} else {
return nullptr;
}
}
const DeclTypeSpec *FindParentTypeSpec(const Scope &scope) {
if (scope.kind() == Scope::Kind::DerivedType) {
if (const auto *symbol{scope.symbol()}) {
return FindParentTypeSpec(*symbol);
}
}
return nullptr;
}
const DeclTypeSpec *FindParentTypeSpec(const Symbol &symbol) {
if (const Scope * scope{symbol.scope()}) {
if (const auto *details{symbol.detailsIf<DerivedTypeDetails>()}) {
if (const Symbol * parent{details->GetParentComponent(*scope)}) {
return parent->GetType();
}
}
}
return nullptr;
}
// When an construct association maps to a variable, and that variable
// is not an array with a vector-valued subscript, return the base
// Symbol of that variable, else nullptr. Descends into other construct
@ -442,6 +487,8 @@ bool IsSaved(const Symbol &symbol) {
return true;
} else if (scopeKind == Scope::Kind::DerivedType) {
return false; // this is a component
} else if (IsNamedConstant(symbol)) {
return false;
} else if (symbol.attrs().test(Attr::SAVE)) {
return true;
} else {
@ -1176,6 +1223,15 @@ FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &derived) {
ultimates.begin(), ultimates.end(), IsPolymorphicAllocatable);
}
UltimateComponentIterator::const_iterator
FindPolymorphicAllocatableNonCoarrayUltimateComponent(
const DerivedTypeSpec &derived) {
UltimateComponentIterator ultimates{derived};
return std::find_if(ultimates.begin(), ultimates.end(), [](const Symbol &x) {
return IsPolymorphicAllocatable(x) && !IsCoarray(x);
});
}
const Symbol *FindUltimateComponent(const DerivedTypeSpec &derived,
const std::function<bool(const Symbol &)> &predicate) {
UltimateComponentIterator ultimates{derived};

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

@ -46,6 +46,12 @@ const Symbol *FindPointerComponent(const Symbol &);
const Symbol *FindInterface(const Symbol &);
const Symbol *FindSubprogram(const Symbol &);
const Symbol *FindFunctionResult(const Symbol &);
const Symbol *FindOverriddenBinding(const Symbol &);
const DeclTypeSpec *FindParentTypeSpec(const DerivedTypeSpec &);
const DeclTypeSpec *FindParentTypeSpec(const DeclTypeSpec &);
const DeclTypeSpec *FindParentTypeSpec(const Scope &);
const DeclTypeSpec *FindParentTypeSpec(const Symbol &);
// Return the Symbol of the variable of a construct association, if it exists
const Symbol *GetAssociationRoot(const Symbol &);
@ -443,6 +449,8 @@ UltimateComponentIterator::const_iterator FindAllocatableUltimateComponent(
const DerivedTypeSpec &);
UltimateComponentIterator::const_iterator
FindPolymorphicAllocatableUltimateComponent(const DerivedTypeSpec &);
UltimateComponentIterator::const_iterator
FindPolymorphicAllocatableNonCoarrayUltimateComponent(const DerivedTypeSpec &);
}
#endif // FORTRAN_SEMANTICS_TOOLS_H_

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

@ -184,10 +184,12 @@ set(ERROR_TESTS
call08.f90
call09.f90
call10.f90
call11.f90
call13.f90
call14.f90
misc-declarations.f90
separate-module-procs.f90
bindings01.f90
)
# These test files have expected symbols in the source

127
flang/test/semantics/bindings01.f90 Normal file
View File

@ -0,0 +1,127 @@
! 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.
! Confirm enforcement of constraints and restrictions in 7.5.7.3
! and C779-C785.
module m
!ERROR: An ABSTRACT derived type must be extensible
type, abstract, bind(c) :: badAbstract1
end type
!ERROR: An ABSTRACT derived type must be extensible
type, abstract :: badAbstract2
sequence
end type
type, abstract :: abstract
contains
!ERROR: DEFERRED is required when an interface-name is provided
procedure(s1), pass :: ab1
!ERROR: Type-bound procedure 'ab3' may not be both DEFERRED and NON_OVERRIDABLE
procedure(s1), deferred, non_overridable :: ab3
!ERROR: DEFERRED is only allowed when an interface-name is provided
procedure, deferred, non_overridable :: ab4 => s1
end type
type :: nonoverride
contains
procedure, non_overridable, nopass :: no1 => s1
end type
type, extends(nonoverride) :: nonoverride2
end type
type, extends(nonoverride2) :: nonoverride3
contains
!ERROR: Override of NON_OVERRIDABLE 'no1' is not permitted
procedure, nopass :: no1 => s1
end type
type, abstract :: missing
contains
procedure(s4), deferred :: am1
end type
!ERROR: Non-ABSTRACT extension of ABSTRACT derived type 'missing' lacks a binding for DEFERRED procedure 'am1'
type, extends(missing) :: concrete
end type
type, extends(missing) :: intermediate
contains
procedure :: am1 => s7
end type
type, extends(intermediate) :: concrete2 ! ensure no false missing binding error
end type
type, bind(c) :: inextensible1
end type
!ERROR: The parent type is not extensible
type, extends(inextensible1) :: badExtends1
end type
type :: inextensible2
sequence
end type
!ERROR: The parent type is not extensible
type, extends(inextensible2) :: badExtends2
end type
!ERROR: Derived type 'real' not found
type, extends(real) :: badExtends3
end type
type :: base
real :: component
contains
!ERROR: Procedure bound to non-ABSTRACT derived type 'base' may not be DEFERRED
procedure(s2), deferred :: bb1
!ERROR: DEFERRED is only allowed when an interface-name is provided
procedure, deferred :: bb2 => s2
end type
type, extends(base) :: extension
contains
!ERROR: A type-bound procedure binding may not have the same name as a parent component
procedure :: component => s3
end type
type :: nopassBase
contains
procedure, nopass :: tbp => s1
end type
type, extends(nopassBase) :: passExtends
contains
!ERROR: A passed-argument type-bound procedure may not override a NOPASS procedure
procedure :: tbp => s5
end type
type :: passBase
contains
procedure :: tbp => s6
end type
type, extends(passBase) :: nopassExtends
contains
!ERROR: A NOPASS type-bound procedure may not override a passed-argument procedure
procedure, nopass :: tbp => s1
end type
contains
subroutine s1(x)
class(abstract), intent(in) :: x
end subroutine s1
subroutine s2(x)
class(base), intent(in) :: x
end subroutine s2
subroutine s3(x)
class(extension), intent(in) :: x
end subroutine s3
subroutine s4(x)
class(missing), intent(in) :: x
end subroutine s4
subroutine s5(x)
class(passExtends), intent(in) :: x
end subroutine s5
subroutine s6(x)
class(passBase), intent(in) :: x
end subroutine s6
subroutine s7(x)
class(intermediate), intent(in) :: x
end subroutine s7
end module

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

@ -154,7 +154,7 @@ module m
!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
!ERROR: Deallocation of polymorphic non-coarray component '%a' is not permitted in a PURE subprogram
to = auto
end subroutine
pure subroutine s12

8
flang/test/semantics/call11.f90
View File

@ -39,15 +39,15 @@ module m
subroutine test
real :: a(pure(1)) ! ok
!ERROR: A function referenced in a specification expression must be PURE
!ERROR: Invalid specification expression: reference to impure function 'impure'
real :: b(impure(1)) ! 10.1.11(4)
forall (j=1:1)
!ERROR: A procedure referenced in a FORALL body must be PURE
!ERROR: Impure procedure 'impure' may not be referenced in a FORALL
a(j) = impure(j) ! C1037
end forall
!ERROR: concurrent-header mask expression cannot reference an impure procedure
!ERROR: Concurrent-header mask expression cannot reference an impure procedure
do concurrent (j=1:1, impure(j) /= 0) ! C1121
!ERROR: call to impure procedure in DO CONCURRENT not allowed
!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
a(j) = impure(j) ! C1139
end do
end subroutine

6
flang/test/semantics/modfile10.f90
View File

@ -32,6 +32,9 @@ module m
private
final :: c
procedure, non_overridable :: d
end type
type, abstract :: t2a
contains
procedure(a), deferred, public, nopass :: e
end type
type t3
@ -76,6 +79,9 @@ end module
! contains
! final::c
! procedure,pass(x),non_overridable,private::d
! end type
! type,abstract::t2a
! contains
! procedure(a),deferred,nopass::e
! end type
! type::t3

4
flang/test/semantics/resolve31.f90
View File

@ -55,8 +55,10 @@ module m4
sequence
private ! not a fatal error
end type
type :: t1a
end type
!ERROR: A sequence type may not have the EXTENDS attribute
type, extends(t1) :: t2
type, extends(t1a) :: t2
sequence
integer i
end type

7
flang/test/semantics/resolve32.f90
View File

@ -53,12 +53,15 @@ module m
procedure, nopass :: i
!ERROR: Type parameter, component, or procedure binding 'b' already defined in this type
procedure, nopass :: b => s4
!ERROR: DEFERRED is required when an interface-name is provided
procedure(foo), nopass :: g
end type
type, abstract :: t1a ! DEFERRED valid only in ABSTRACT derived type
contains
procedure(foo), nopass, deferred :: e
procedure(s), nopass, deferred :: f
!ERROR: Type parameter, component, or procedure binding 'f' already defined in this type
procedure(foo), nopass, deferred :: f
!ERROR: DEFERRED is required when an interface-name is provided
procedure(foo), nopass :: g
!ERROR: 'bar' must be an abstract interface or a procedure with an explicit interface
procedure(bar), nopass, deferred :: h
end type

4
flang/test/semantics/resolve52.f90
View File

@ -123,7 +123,7 @@ end
module m7
type :: t
sequence ! t is not extensible
!ERROR: Passed-object dummy argument 'x' of procedure 'a' must not be polymorphic because 't' is not extensible
!ERROR: Passed-object dummy argument 'x' of procedure 'a' may not be polymorphic because 't' is not extensible
procedure(s), pointer :: a
end type
contains
@ -135,7 +135,7 @@ end
module m8
type :: t
contains
!ERROR: Passed-object dummy argument 'x' of procedure 's' must polymorphic because 't' is extensible
!ERROR: Passed-object dummy argument 'x' of procedure 's' must be polymorphic because 't' is extensible
procedure :: s
end type
contains