[flang] Consolidate & clean up COMMON block checks #161286
Merged
Conversation
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
COMMON block checks are split between name resolution and declaration checking. We generally want declaration checks to take place after name resolution, and the COMMON block checks that are currently in name resolution have some derived type analyses that are redundant with the derived type component iteration framework used elsewhere in semantics. So move as much as possible into declaration checking, use the component iteration framework, and cope with the missing COMMON block name case that arises with blank COMMON when placing the error messages.
llvmbot
added
flang
|
@llvm/pr-subscribers-flang-parser @llvm/pr-subscribers-flang-openmp Author: Peter Klausler (klausler) ChangesCOMMON block checks are split between name resolution and declaration checking. We generally want declaration checks to take place after name resolution, and the COMMON block checks that are currently in name resolution have some derived type analyses that are redundant with the derived type component iteration framework used elsewhere in semantics. So move as much as possible into declaration checking, use the component iteration framework, and cope with the missing COMMON block name case that arises with blank COMMON when placing the error messages. Patch is 25.82 KiB, truncated to 20.00 KiB below, full version: https://github.com/llvm/llvm-project/pull/161286.diff 15 Files Affected:
diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index be30a95763208..4920808af5423 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -1639,6 +1639,7 @@ struct CommonStmt {
BOILERPLATE(CommonStmt);
CommonStmt(std::optional<Name> &&, std::list<CommonBlockObject> &&,
std::list<Block> &&);
+ CharBlock source;
std::list<Block> blocks;
};
diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h
index b4046830522b8..3195892fa7b91 100644
--- a/flang/include/flang/Semantics/scope.h
+++ b/flang/include/flang/Semantics/scope.h
@@ -188,7 +188,7 @@ class Scope {
void add_crayPointer(const SourceName &, Symbol &);
mapType &commonBlocks() { return commonBlocks_; }
const mapType &commonBlocks() const { return commonBlocks_; }
- Symbol &MakeCommonBlock(const SourceName &);
+ Symbol &MakeCommonBlock(SourceName, SourceName location);
Symbol *FindCommonBlock(const SourceName &) const;
/// Make a Symbol but don't add it to the scope.
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index e90e9c617805d..afe8795e7aca6 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -570,17 +570,21 @@ class NamelistDetails {
class CommonBlockDetails : public WithBindName {
public:
+ explicit CommonBlockDetails(SourceName location)
+ : sourceLocation_{location} {}
+ SourceName sourceLocation() const { return sourceLocation_; }
MutableSymbolVector &objects() { return objects_; }
const MutableSymbolVector &objects() const { return objects_; }
void add_object(Symbol &object) { objects_.emplace_back(object); }
void replace_object(Symbol &object, unsigned index) {
- CHECK(index < (unsigned)objects_.size());
+ CHECK(index < objects_.size());
objects_[index] = object;
}
std::size_t alignment() const { return alignment_; }
void set_alignment(std::size_t alignment) { alignment_ = alignment; }
private:
+ SourceName sourceLocation_;
MutableSymbolVector objects_;
std::size_t alignment_{0}; // required alignment in bytes
};
diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index 5d96f1e89bf52..3bd638b89053d 100644
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -285,6 +285,9 @@ class DerivedTypeSpec {
bool IsForwardReferenced() const;
bool HasDefaultInitialization(
bool ignoreAllocatable = false, bool ignorePointer = true) const;
+ std::optional<std::string> // component path suitable for error messages
+ ComponentWithDefaultInitialization(
+ bool ignoreAllocatable = false, bool ignorePointer = true) const;
bool HasDestruction() const;
// The "raw" type parameter list is a simple transcription from the
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 1f3cbbf6a0c36..8c15375602712 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1209,6 +1209,15 @@ parser::Message *AttachDeclaration(
message.Attach(use->location(),
"'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
unhosted->name(), GetUsedModule(*use).name());
+ } else if (const auto *common{
+ unhosted->detailsIf<semantics::CommonBlockDetails>()}) {
+ parser::CharBlock at{unhosted->name()};
+ if (at.empty()) { // blank COMMON, with or without //
+ at = common->sourceLocation();
+ }
+ if (!at.empty()) {
+ message.Attach(at, "Declaration of /%s/"_en_US, unhosted->name());
+ }
} else {
message.Attach(
unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index fbe629ab52935..d33a18fe9572c 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -1100,14 +1100,14 @@ TYPE_PARSER(construct<EquivalenceObject>(indirect(designator)))
// R873 common-stmt ->
// COMMON [/ [common-block-name] /] common-block-object-list
// [[,] / [common-block-name] / common-block-object-list]...
-TYPE_PARSER(
+TYPE_PARSER(sourced(
construct<CommonStmt>("COMMON" >> defaulted("/" >> maybe(name) / "/"),
nonemptyList("expected COMMON block objects"_err_en_US,
Parser<CommonBlockObject>{}),
many(maybe(","_tok) >>
construct<CommonStmt::Block>("/" >> maybe(name) / "/",
nonemptyList("expected COMMON block objects"_err_en_US,
- Parser<CommonBlockObject>{})))))
+ Parser<CommonBlockObject>{}))))))
// R874 common-block-object -> variable-name [( array-spec )]
TYPE_PARSER(construct<CommonBlockObject>(name, maybe(arraySpec)))
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 1049a6d2c1b2e..fce0b9c49139b 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -512,39 +512,111 @@ void CheckHelper::Check(const Symbol &symbol) {
}
void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
- auto restorer{messages_.SetLocation(symbol.name())};
CheckGlobalName(symbol);
- if (symbol.attrs().test(Attr::BIND_C)) {
+ const auto &common{symbol.get<CommonBlockDetails>()};
+ SourceName location{symbol.name()};
+ if (location.empty()) {
+ location = common.sourceLocation();
+ }
+ bool isBindCCommon{symbol.attrs().test(Attr::BIND_C)};
+ if (isBindCCommon) {
CheckBindC(symbol);
- for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
- if (ref->has<ObjectEntityDetails>()) {
- if (auto msgs{WhyNotInteroperableObject(*ref,
- /*allowInteroperableType=*/false, /*forCommonBlock=*/true)};
- !msgs.empty()) {
- parser::Message &reason{msgs.messages().front()};
- parser::Message *msg{nullptr};
- if (reason.IsFatal()) {
- msg = messages_.Say(symbol.name(),
- "'%s' may not be a member of BIND(C) COMMON block /%s/"_err_en_US,
- ref->name(), symbol.name());
- } else {
- msg = messages_.Say(symbol.name(),
- "'%s' should not be a member of BIND(C) COMMON block /%s/"_warn_en_US,
- ref->name(), symbol.name());
- }
- if (msg) {
- msg->Attach(
- std::move(reason.set_severity(parser::Severity::Because)));
- }
+ }
+ for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
+ auto restorer{
+ messages_.SetLocation(location.empty() ? ref->name() : location)};
+ if (isBindCCommon && ref->has<ObjectEntityDetails>()) {
+ if (auto msgs{WhyNotInteroperableObject(*ref,
+ /*allowInteroperableType=*/false, /*forCommonBlock=*/true)};
+ !msgs.empty()) {
+ parser::Message &reason{msgs.messages().front()};
+ parser::Message *msg{nullptr};
+ if (reason.IsFatal()) {
+ msg = messages_.Say(
+ "'%s' may not be a member of BIND(C) COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name());
+ } else {
+ msg = messages_.Say(
+ "'%s' should not be a member of BIND(C) COMMON block /%s/"_warn_en_US,
+ ref->name(), symbol.name());
}
+ if (msg) {
+ msg = &msg->Attach(
+ std::move(reason.set_severity(parser::Severity::Because)));
+ }
+ evaluate::AttachDeclaration(msg, *ref);
}
}
- }
- for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
if (ref->test(Symbol::Flag::CrayPointee)) {
- messages_.Say(ref->name(),
- "Cray pointee '%s' may not be a member of a COMMON block"_err_en_US,
- ref->name());
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Cray pointee '%s' may not be a member of COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsAllocatable(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "ALLOCATABLE object '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (ref->attrs().test(Attr::BIND_C)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "BIND(C) object '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsNamedConstant(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Named constant '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsDummy(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Dummy argument '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (ref->IsFuncResult()) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Function result '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (const auto *type{ref->GetType()}) {
+ if (type->category() == DeclTypeSpec::ClassStar) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Unlimited polymorphic pointer '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ } else if (const auto *derived{type->AsDerived()}) {
+ if (!IsSequenceOrBindCType(derived)) {
+ evaluate::AttachDeclaration(
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Object '%s' whose derived type '%s' is neither SEQUENCE nor BIND(C) may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), derived->name(), symbol.name()),
+ derived->typeSymbol()),
+ *ref);
+ } else if (auto componentPath{
+ derived->ComponentWithDefaultInitialization()}) {
+ evaluate::AttachDeclaration(
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "COMMON block /%s/ may not have the member '%s' whose derived type '%s' has a component '%s' that is ALLOCATABLE or has default initialization"_err_en_US,
+ symbol.name(), ref->name(), derived->name(),
+ *componentPath),
+ derived->typeSymbol()),
+ *ref);
+ }
+ }
}
}
}
diff --git a/flang/lib/Semantics/resolve-directives.cpp b/flang/lib/Semantics/resolve-directives.cpp
index 218e3e7266ca9..683c798f2f6c5 100644
--- a/flang/lib/Semantics/resolve-directives.cpp
+++ b/flang/lib/Semantics/resolve-directives.cpp
@@ -603,7 +603,7 @@ class OmpAttributeVisitor : DirectiveAttributeVisitor<llvm::omp::Directive> {
for (const parser::OmpObject &obj : x.v) {
auto *name{std::get_if<parser::Name>(&obj.u)};
if (name && !name->symbol) {
- Resolve(*name, currScope().MakeCommonBlock(name->source));
+ Resolve(*name, currScope().MakeCommonBlock(name->source, name->source));
}
}
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 43b49e01c89c7..f3704fc4e720a 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1105,8 +1105,9 @@ class DeclarationVisitor : public ArraySpecVisitor,
// or nullptr on error.
Symbol *DeclareStatementEntity(const parser::DoVariable &,
const std::optional<parser::IntegerTypeSpec> &);
- Symbol &MakeCommonBlockSymbol(const parser::Name &);
- Symbol &MakeCommonBlockSymbol(const std::optional<parser::Name> &);
+ Symbol &MakeCommonBlockSymbol(const parser::Name &, SourceName);
+ Symbol &MakeCommonBlockSymbol(
+ const std::optional<parser::Name> &, SourceName);
bool CheckUseError(const parser::Name &);
void CheckAccessibility(const SourceName &, bool, Symbol &);
void CheckCommonBlocks();
@@ -1243,8 +1244,6 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool OkToAddComponent(const parser::Name &, const Symbol *extends = nullptr);
ParamValue GetParamValue(
const parser::TypeParamValue &, common::TypeParamAttr attr);
- void CheckCommonBlockDerivedType(
- const SourceName &, const Symbol &, UnorderedSymbolSet &);
Attrs HandleSaveName(const SourceName &, Attrs);
void AddSaveName(std::set<SourceName> &, const SourceName &);
bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
@@ -5508,7 +5507,7 @@ bool DeclarationVisitor::Pre(const parser::BindEntity &x) {
if (kind == parser::BindEntity::Kind::Object) {
symbol = &HandleAttributeStmt(Attr::BIND_C, name);
} else {
- symbol = &MakeCommonBlockSymbol(name);
+ symbol = &MakeCommonBlockSymbol(name, name.source);
SetExplicitAttr(*symbol, Attr::BIND_C);
}
// 8.6.4(1)
@@ -7090,7 +7089,7 @@ bool DeclarationVisitor::Pre(const parser::SaveStmt &x) {
auto kind{std::get<parser::SavedEntity::Kind>(y.t)};
const auto &name{std::get<parser::Name>(y.t)};
if (kind == parser::SavedEntity::Kind::Common) {
- MakeCommonBlockSymbol(name);
+ MakeCommonBlockSymbol(name, name.source);
AddSaveName(specPartState_.saveInfo.commons, name.source);
} else {
HandleAttributeStmt(Attr::SAVE, name);
@@ -7170,59 +7169,22 @@ void DeclarationVisitor::CheckCommonBlocks() {
if (symbol.get<CommonBlockDetails>().objects().empty() &&
symbol.attrs().test(Attr::BIND_C)) {
Say(symbol.name(),
- "'%s' appears as a COMMON block in a BIND statement but not in"
- " a COMMON statement"_err_en_US);
- }
- }
- // check objects in common blocks
- for (const auto &name : specPartState_.commonBlockObjects) {
- const auto *symbol{currScope().FindSymbol(name)};
- if (!symbol) {
- continue;
- }
- const auto &attrs{symbol->attrs()};
- if (attrs.test(Attr::ALLOCATABLE)) {
- Say(name,
- "ALLOCATABLE object '%s' may not appear in a COMMON block"_err_en_US);
- } else if (attrs.test(Attr::BIND_C)) {
- Say(name,
- "Variable '%s' with BIND attribute may not appear in a COMMON block"_err_en_US);
- } else if (IsNamedConstant(*symbol)) {
- Say(name,
- "A named constant '%s' may not appear in a COMMON block"_err_en_US);
- } else if (IsDummy(*symbol)) {
- Say(name,
- "Dummy argument '%s' may not appear in a COMMON block"_err_en_US);
- } else if (symbol->IsFuncResult()) {
- Say(name,
- "Function result '%s' may not appear in a COMMON block"_err_en_US);
- } else if (const DeclTypeSpec * type{symbol->GetType()}) {
- if (type->category() == DeclTypeSpec::ClassStar) {
- Say(name,
- "Unlimited polymorphic pointer '%s' may not appear in a COMMON block"_err_en_US);
- } else if (const auto *derived{type->AsDerived()}) {
- if (!IsSequenceOrBindCType(derived)) {
- Say(name,
- "Derived type '%s' in COMMON block must have the BIND or"
- " SEQUENCE attribute"_err_en_US);
- }
- UnorderedSymbolSet typeSet;
- CheckCommonBlockDerivedType(name, derived->typeSymbol(), typeSet);
- }
+ "'%s' appears as a COMMON block in a BIND statement but not in a COMMON statement"_err_en_US);
}
}
specPartState_.commonBlockObjects = {};
}
-Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) {
- return Resolve(name, currScope().MakeCommonBlock(name.source));
+Symbol &DeclarationVisitor::MakeCommonBlockSymbol(
+ const parser::Name &name, SourceName location) {
+ return Resolve(name, currScope().MakeCommonBlock(name.source, location));
}
Symbol &DeclarationVisitor::MakeCommonBlockSymbol(
- const std::optional<parser::Name> &name) {
+ const std::optional<parser::Name> &name, SourceName location) {
if (name) {
- return MakeCommonBlockSymbol(*name);
+ return MakeCommonBlockSymbol(*name, location);
} else {
- return MakeCommonBlockSymbol(parser::Name{});
+ return MakeCommonBlockSymbol(parser::Name{}, location);
}
}
@@ -7230,43 +7192,6 @@ bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) {
return FindSymbol(name) || HandleUnrestrictedSpecificIntrinsicFunction(name);
}
-// Check if this derived type can be in a COMMON block.
-void DeclarationVisitor::CheckCommonBlockDerivedType(const SourceName &name,
- const Symbol &typeSymbol, UnorderedSymbolSet &typeSet) {
- if (auto iter{typeSet.find(SymbolRef{typeSymbol})}; iter != typeSet.end()) {
- return;
- }
- typeSet.emplace(typeSymbol);
- if (const auto *scope{typeSymbol.scope()}) {
- for (const auto &pair : *scope) {
- const Symbol &component{*pair.second};
- if (component.attrs().test(Attr::ALLOCATABLE)) {
- Say2(name,
- "Derived type variable '%s' may not appear in a COMMON block"
- " due to ALLOCATABLE component"_err_en_US,
- component.name(), "Component with ALLOCATABLE attribute"_en_US);
- return;
- }
- const auto *details{component.detailsIf<ObjectEntityDetails>()};
- if (component.test(Symbol::Flag::InDataStmt) ||
- (details && details->init())) {
- Say2(name,
- "Derived type variable '%s' may not appear in a COMMON block due to component with default initialization"_err_en_US,
- component.name(), "Component with default initialization"_en_US);
- return;
- }
- if (details) {
- if (const auto *type{details->type()}) {
- if (const auto *derived{type->AsDerived()}) {
- const Symbol &derivedTypeSymbol{derived->typeSymbol()};
- CheckCommonBlockDerivedType(name, derivedTypeSymbol, typeSet);
- }
- }
- }
- }
- }
-}
-
bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
const parser::Name &name) {
if (auto interface{context().intrinsics().IsSpecificIntrinsicFunction(
@@ -9598,7 +9523,7 @@ void ResolveNamesVisitor::CreateCommonBlockSymbols(
const parser::CommonStmt &commonStmt) {
for (const parser::CommonStmt::Block &block : commonStmt.blocks) {
const auto &[name, objects] = block.t;
- Symbol &commonBlock{MakeCommonBlockSymbol(name)};
+ Symbol &commonBlock{MakeCommonBlockSymbol(name, commonStmt.source)};
for (const auto &object : objects) {
Symbol &obj{DeclareObjectEntity(std::get<parser::Name>(object.t))};
if (auto *details{obj.detailsIf<ObjectEntityDetails>()}) {
diff --git a/flang/lib/Semantics/scope.cpp b/flang/lib/Semantics/scope.cpp
index 9c5682bed06cb..4af371f3611f3 100644
--- a/flang/lib/Semantics/scope.cpp
+++ b/flang/lib/Semantics/scope.cpp
@@ -143,12 +143,13 @@ void Scope::add_crayPointer(const SourceName &name, Symbol &pointer) {
crayPointers_.emplace(name, pointer);
}
-Symbol &Scope::MakeCommonBlock(const SourceName &name) {
+Symbol &Scope::MakeCommonBlock(SourceName name, SourceName location) {
const auto it{commonBlocks_.find(name)};
if (it != commonBlocks_.end()) {
return *it->second;
} else {
- Symbol &symbol{MakeSymbol(name, Attrs{}, CommonBlockDetails{})};
+ Symbol &symbol{MakeSymbol(
+ name, Attrs{}, CommonBlockDetails{name.empty() ? location : name})};
commonBlocks_.emplace(name, symbol);
return symbol;
}
diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp
index 6db11aaf56c2a..bdb5377265c14 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -313,15 +313,13 @@ class CommonBlockMap {
/// Return the symbol of an initialized member if a COMMON block
/// is initalized. Otherwise, return nullptr.
static Symbol *CommonBlockIsInitialized(const Symbol &common) {
- const auto &commonDetails =
- common.get<Fortran::semantics::CommonBlockDetails>();
-
+ const auto &commonDetails{
+ common.get<Fortran::semantics::CommonBlockDetails>()};
fo...
[truncated]
|
|
@llvm/pr-subscribers-flang-semantics Author: Peter Klausler (klausler) ChangesCOMMON block checks are split between name resolution and declaration checking. We generally want declaration checks to take place after name resolution, and the COMMON block checks that are currently in name resolution have some derived type analyses that are redundant with the derived type component iteration framework used elsewhere in semantics. So move as much as possible into declaration checking, use the component iteration framework, and cope with the missing COMMON block name case that arises with blank COMMON when placing the error messages. Patch is 25.82 KiB, truncated to 20.00 KiB below, full version: https://github.com/llvm/llvm-project/pull/161286.diff 15 Files Affected:
diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index be30a95763208..4920808af5423 100644
--- a/flang/include/flang/Parser/parse-tree.h
+++ b/flang/include/flang/Parser/parse-tree.h
@@ -1639,6 +1639,7 @@ struct CommonStmt {
BOILERPLATE(CommonStmt);
CommonStmt(std::optional<Name> &&, std::list<CommonBlockObject> &&,
std::list<Block> &&);
+ CharBlock source;
std::list<Block> blocks;
};
diff --git a/flang/include/flang/Semantics/scope.h b/flang/include/flang/Semantics/scope.h
index b4046830522b8..3195892fa7b91 100644
--- a/flang/include/flang/Semantics/scope.h
+++ b/flang/include/flang/Semantics/scope.h
@@ -188,7 +188,7 @@ class Scope {
void add_crayPointer(const SourceName &, Symbol &);
mapType &commonBlocks() { return commonBlocks_; }
const mapType &commonBlocks() const { return commonBlocks_; }
- Symbol &MakeCommonBlock(const SourceName &);
+ Symbol &MakeCommonBlock(SourceName, SourceName location);
Symbol *FindCommonBlock(const SourceName &) const;
/// Make a Symbol but don't add it to the scope.
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index e90e9c617805d..afe8795e7aca6 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -570,17 +570,21 @@ class NamelistDetails {
class CommonBlockDetails : public WithBindName {
public:
+ explicit CommonBlockDetails(SourceName location)
+ : sourceLocation_{location} {}
+ SourceName sourceLocation() const { return sourceLocation_; }
MutableSymbolVector &objects() { return objects_; }
const MutableSymbolVector &objects() const { return objects_; }
void add_object(Symbol &object) { objects_.emplace_back(object); }
void replace_object(Symbol &object, unsigned index) {
- CHECK(index < (unsigned)objects_.size());
+ CHECK(index < objects_.size());
objects_[index] = object;
}
std::size_t alignment() const { return alignment_; }
void set_alignment(std::size_t alignment) { alignment_ = alignment; }
private:
+ SourceName sourceLocation_;
MutableSymbolVector objects_;
std::size_t alignment_{0}; // required alignment in bytes
};
diff --git a/flang/include/flang/Semantics/type.h b/flang/include/flang/Semantics/type.h
index 5d96f1e89bf52..3bd638b89053d 100644
--- a/flang/include/flang/Semantics/type.h
+++ b/flang/include/flang/Semantics/type.h
@@ -285,6 +285,9 @@ class DerivedTypeSpec {
bool IsForwardReferenced() const;
bool HasDefaultInitialization(
bool ignoreAllocatable = false, bool ignorePointer = true) const;
+ std::optional<std::string> // component path suitable for error messages
+ ComponentWithDefaultInitialization(
+ bool ignoreAllocatable = false, bool ignorePointer = true) const;
bool HasDestruction() const;
// The "raw" type parameter list is a simple transcription from the
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 1f3cbbf6a0c36..8c15375602712 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1209,6 +1209,15 @@ parser::Message *AttachDeclaration(
message.Attach(use->location(),
"'%s' is USE-associated with '%s' in module '%s'"_en_US, symbol.name(),
unhosted->name(), GetUsedModule(*use).name());
+ } else if (const auto *common{
+ unhosted->detailsIf<semantics::CommonBlockDetails>()}) {
+ parser::CharBlock at{unhosted->name()};
+ if (at.empty()) { // blank COMMON, with or without //
+ at = common->sourceLocation();
+ }
+ if (!at.empty()) {
+ message.Attach(at, "Declaration of /%s/"_en_US, unhosted->name());
+ }
} else {
message.Attach(
unhosted->name(), "Declaration of '%s'"_en_US, unhosted->name());
diff --git a/flang/lib/Parser/Fortran-parsers.cpp b/flang/lib/Parser/Fortran-parsers.cpp
index fbe629ab52935..d33a18fe9572c 100644
--- a/flang/lib/Parser/Fortran-parsers.cpp
+++ b/flang/lib/Parser/Fortran-parsers.cpp
@@ -1100,14 +1100,14 @@ TYPE_PARSER(construct<EquivalenceObject>(indirect(designator)))
// R873 common-stmt ->
// COMMON [/ [common-block-name] /] common-block-object-list
// [[,] / [common-block-name] / common-block-object-list]...
-TYPE_PARSER(
+TYPE_PARSER(sourced(
construct<CommonStmt>("COMMON" >> defaulted("/" >> maybe(name) / "/"),
nonemptyList("expected COMMON block objects"_err_en_US,
Parser<CommonBlockObject>{}),
many(maybe(","_tok) >>
construct<CommonStmt::Block>("/" >> maybe(name) / "/",
nonemptyList("expected COMMON block objects"_err_en_US,
- Parser<CommonBlockObject>{})))))
+ Parser<CommonBlockObject>{}))))))
// R874 common-block-object -> variable-name [( array-spec )]
TYPE_PARSER(construct<CommonBlockObject>(name, maybe(arraySpec)))
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 1049a6d2c1b2e..fce0b9c49139b 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -512,39 +512,111 @@ void CheckHelper::Check(const Symbol &symbol) {
}
void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
- auto restorer{messages_.SetLocation(symbol.name())};
CheckGlobalName(symbol);
- if (symbol.attrs().test(Attr::BIND_C)) {
+ const auto &common{symbol.get<CommonBlockDetails>()};
+ SourceName location{symbol.name()};
+ if (location.empty()) {
+ location = common.sourceLocation();
+ }
+ bool isBindCCommon{symbol.attrs().test(Attr::BIND_C)};
+ if (isBindCCommon) {
CheckBindC(symbol);
- for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
- if (ref->has<ObjectEntityDetails>()) {
- if (auto msgs{WhyNotInteroperableObject(*ref,
- /*allowInteroperableType=*/false, /*forCommonBlock=*/true)};
- !msgs.empty()) {
- parser::Message &reason{msgs.messages().front()};
- parser::Message *msg{nullptr};
- if (reason.IsFatal()) {
- msg = messages_.Say(symbol.name(),
- "'%s' may not be a member of BIND(C) COMMON block /%s/"_err_en_US,
- ref->name(), symbol.name());
- } else {
- msg = messages_.Say(symbol.name(),
- "'%s' should not be a member of BIND(C) COMMON block /%s/"_warn_en_US,
- ref->name(), symbol.name());
- }
- if (msg) {
- msg->Attach(
- std::move(reason.set_severity(parser::Severity::Because)));
- }
+ }
+ for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
+ auto restorer{
+ messages_.SetLocation(location.empty() ? ref->name() : location)};
+ if (isBindCCommon && ref->has<ObjectEntityDetails>()) {
+ if (auto msgs{WhyNotInteroperableObject(*ref,
+ /*allowInteroperableType=*/false, /*forCommonBlock=*/true)};
+ !msgs.empty()) {
+ parser::Message &reason{msgs.messages().front()};
+ parser::Message *msg{nullptr};
+ if (reason.IsFatal()) {
+ msg = messages_.Say(
+ "'%s' may not be a member of BIND(C) COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name());
+ } else {
+ msg = messages_.Say(
+ "'%s' should not be a member of BIND(C) COMMON block /%s/"_warn_en_US,
+ ref->name(), symbol.name());
}
+ if (msg) {
+ msg = &msg->Attach(
+ std::move(reason.set_severity(parser::Severity::Because)));
+ }
+ evaluate::AttachDeclaration(msg, *ref);
}
}
- }
- for (auto ref : symbol.get<CommonBlockDetails>().objects()) {
if (ref->test(Symbol::Flag::CrayPointee)) {
- messages_.Say(ref->name(),
- "Cray pointee '%s' may not be a member of a COMMON block"_err_en_US,
- ref->name());
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Cray pointee '%s' may not be a member of COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsAllocatable(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "ALLOCATABLE object '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (ref->attrs().test(Attr::BIND_C)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "BIND(C) object '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsNamedConstant(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Named constant '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (IsDummy(*ref)) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Dummy argument '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (ref->IsFuncResult()) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Function result '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ }
+ if (const auto *type{ref->GetType()}) {
+ if (type->category() == DeclTypeSpec::ClassStar) {
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Unlimited polymorphic pointer '%s' may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), symbol.name()),
+ *ref);
+ } else if (const auto *derived{type->AsDerived()}) {
+ if (!IsSequenceOrBindCType(derived)) {
+ evaluate::AttachDeclaration(
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "Object '%s' whose derived type '%s' is neither SEQUENCE nor BIND(C) may not appear in COMMON block /%s/"_err_en_US,
+ ref->name(), derived->name(), symbol.name()),
+ derived->typeSymbol()),
+ *ref);
+ } else if (auto componentPath{
+ derived->ComponentWithDefaultInitialization()}) {
+ evaluate::AttachDeclaration(
+ evaluate::AttachDeclaration(
+ messages_.Say(
+ "COMMON block /%s/ may not have the member '%s' whose derived type '%s' has a component '%s' that is ALLOCATABLE or has default initialization"_err_en_US,
+ symbol.name(), ref->name(), derived->name(),
+ *componentPath),
+ derived->typeSymbol()),
+ *ref);
+ }
+ }
}
}
}
diff --git a/flang/lib/Semantics/resolve-directives.cpp b/flang/lib/Semantics/resolve-directives.cpp
index 218e3e7266ca9..683c798f2f6c5 100644
--- a/flang/lib/Semantics/resolve-directives.cpp
+++ b/flang/lib/Semantics/resolve-directives.cpp
@@ -603,7 +603,7 @@ class OmpAttributeVisitor : DirectiveAttributeVisitor<llvm::omp::Directive> {
for (const parser::OmpObject &obj : x.v) {
auto *name{std::get_if<parser::Name>(&obj.u)};
if (name && !name->symbol) {
- Resolve(*name, currScope().MakeCommonBlock(name->source));
+ Resolve(*name, currScope().MakeCommonBlock(name->source, name->source));
}
}
}
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 43b49e01c89c7..f3704fc4e720a 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1105,8 +1105,9 @@ class DeclarationVisitor : public ArraySpecVisitor,
// or nullptr on error.
Symbol *DeclareStatementEntity(const parser::DoVariable &,
const std::optional<parser::IntegerTypeSpec> &);
- Symbol &MakeCommonBlockSymbol(const parser::Name &);
- Symbol &MakeCommonBlockSymbol(const std::optional<parser::Name> &);
+ Symbol &MakeCommonBlockSymbol(const parser::Name &, SourceName);
+ Symbol &MakeCommonBlockSymbol(
+ const std::optional<parser::Name> &, SourceName);
bool CheckUseError(const parser::Name &);
void CheckAccessibility(const SourceName &, bool, Symbol &);
void CheckCommonBlocks();
@@ -1243,8 +1244,6 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool OkToAddComponent(const parser::Name &, const Symbol *extends = nullptr);
ParamValue GetParamValue(
const parser::TypeParamValue &, common::TypeParamAttr attr);
- void CheckCommonBlockDerivedType(
- const SourceName &, const Symbol &, UnorderedSymbolSet &);
Attrs HandleSaveName(const SourceName &, Attrs);
void AddSaveName(std::set<SourceName> &, const SourceName &);
bool HandleUnrestrictedSpecificIntrinsicFunction(const parser::Name &);
@@ -5508,7 +5507,7 @@ bool DeclarationVisitor::Pre(const parser::BindEntity &x) {
if (kind == parser::BindEntity::Kind::Object) {
symbol = &HandleAttributeStmt(Attr::BIND_C, name);
} else {
- symbol = &MakeCommonBlockSymbol(name);
+ symbol = &MakeCommonBlockSymbol(name, name.source);
SetExplicitAttr(*symbol, Attr::BIND_C);
}
// 8.6.4(1)
@@ -7090,7 +7089,7 @@ bool DeclarationVisitor::Pre(const parser::SaveStmt &x) {
auto kind{std::get<parser::SavedEntity::Kind>(y.t)};
const auto &name{std::get<parser::Name>(y.t)};
if (kind == parser::SavedEntity::Kind::Common) {
- MakeCommonBlockSymbol(name);
+ MakeCommonBlockSymbol(name, name.source);
AddSaveName(specPartState_.saveInfo.commons, name.source);
} else {
HandleAttributeStmt(Attr::SAVE, name);
@@ -7170,59 +7169,22 @@ void DeclarationVisitor::CheckCommonBlocks() {
if (symbol.get<CommonBlockDetails>().objects().empty() &&
symbol.attrs().test(Attr::BIND_C)) {
Say(symbol.name(),
- "'%s' appears as a COMMON block in a BIND statement but not in"
- " a COMMON statement"_err_en_US);
- }
- }
- // check objects in common blocks
- for (const auto &name : specPartState_.commonBlockObjects) {
- const auto *symbol{currScope().FindSymbol(name)};
- if (!symbol) {
- continue;
- }
- const auto &attrs{symbol->attrs()};
- if (attrs.test(Attr::ALLOCATABLE)) {
- Say(name,
- "ALLOCATABLE object '%s' may not appear in a COMMON block"_err_en_US);
- } else if (attrs.test(Attr::BIND_C)) {
- Say(name,
- "Variable '%s' with BIND attribute may not appear in a COMMON block"_err_en_US);
- } else if (IsNamedConstant(*symbol)) {
- Say(name,
- "A named constant '%s' may not appear in a COMMON block"_err_en_US);
- } else if (IsDummy(*symbol)) {
- Say(name,
- "Dummy argument '%s' may not appear in a COMMON block"_err_en_US);
- } else if (symbol->IsFuncResult()) {
- Say(name,
- "Function result '%s' may not appear in a COMMON block"_err_en_US);
- } else if (const DeclTypeSpec * type{symbol->GetType()}) {
- if (type->category() == DeclTypeSpec::ClassStar) {
- Say(name,
- "Unlimited polymorphic pointer '%s' may not appear in a COMMON block"_err_en_US);
- } else if (const auto *derived{type->AsDerived()}) {
- if (!IsSequenceOrBindCType(derived)) {
- Say(name,
- "Derived type '%s' in COMMON block must have the BIND or"
- " SEQUENCE attribute"_err_en_US);
- }
- UnorderedSymbolSet typeSet;
- CheckCommonBlockDerivedType(name, derived->typeSymbol(), typeSet);
- }
+ "'%s' appears as a COMMON block in a BIND statement but not in a COMMON statement"_err_en_US);
}
}
specPartState_.commonBlockObjects = {};
}
-Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) {
- return Resolve(name, currScope().MakeCommonBlock(name.source));
+Symbol &DeclarationVisitor::MakeCommonBlockSymbol(
+ const parser::Name &name, SourceName location) {
+ return Resolve(name, currScope().MakeCommonBlock(name.source, location));
}
Symbol &DeclarationVisitor::MakeCommonBlockSymbol(
- const std::optional<parser::Name> &name) {
+ const std::optional<parser::Name> &name, SourceName location) {
if (name) {
- return MakeCommonBlockSymbol(*name);
+ return MakeCommonBlockSymbol(*name, location);
} else {
- return MakeCommonBlockSymbol(parser::Name{});
+ return MakeCommonBlockSymbol(parser::Name{}, location);
}
}
@@ -7230,43 +7192,6 @@ bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) {
return FindSymbol(name) || HandleUnrestrictedSpecificIntrinsicFunction(name);
}
-// Check if this derived type can be in a COMMON block.
-void DeclarationVisitor::CheckCommonBlockDerivedType(const SourceName &name,
- const Symbol &typeSymbol, UnorderedSymbolSet &typeSet) {
- if (auto iter{typeSet.find(SymbolRef{typeSymbol})}; iter != typeSet.end()) {
- return;
- }
- typeSet.emplace(typeSymbol);
- if (const auto *scope{typeSymbol.scope()}) {
- for (const auto &pair : *scope) {
- const Symbol &component{*pair.second};
- if (component.attrs().test(Attr::ALLOCATABLE)) {
- Say2(name,
- "Derived type variable '%s' may not appear in a COMMON block"
- " due to ALLOCATABLE component"_err_en_US,
- component.name(), "Component with ALLOCATABLE attribute"_en_US);
- return;
- }
- const auto *details{component.detailsIf<ObjectEntityDetails>()};
- if (component.test(Symbol::Flag::InDataStmt) ||
- (details && details->init())) {
- Say2(name,
- "Derived type variable '%s' may not appear in a COMMON block due to component with default initialization"_err_en_US,
- component.name(), "Component with default initialization"_en_US);
- return;
- }
- if (details) {
- if (const auto *type{details->type()}) {
- if (const auto *derived{type->AsDerived()}) {
- const Symbol &derivedTypeSymbol{derived->typeSymbol()};
- CheckCommonBlockDerivedType(name, derivedTypeSymbol, typeSet);
- }
- }
- }
- }
- }
-}
-
bool DeclarationVisitor::HandleUnrestrictedSpecificIntrinsicFunction(
const parser::Name &name) {
if (auto interface{context().intrinsics().IsSpecificIntrinsicFunction(
@@ -9598,7 +9523,7 @@ void ResolveNamesVisitor::CreateCommonBlockSymbols(
const parser::CommonStmt &commonStmt) {
for (const parser::CommonStmt::Block &block : commonStmt.blocks) {
const auto &[name, objects] = block.t;
- Symbol &commonBlock{MakeCommonBlockSymbol(name)};
+ Symbol &commonBlock{MakeCommonBlockSymbol(name, commonStmt.source)};
for (const auto &object : objects) {
Symbol &obj{DeclareObjectEntity(std::get<parser::Name>(object.t))};
if (auto *details{obj.detailsIf<ObjectEntityDetails>()}) {
diff --git a/flang/lib/Semantics/scope.cpp b/flang/lib/Semantics/scope.cpp
index 9c5682bed06cb..4af371f3611f3 100644
--- a/flang/lib/Semantics/scope.cpp
+++ b/flang/lib/Semantics/scope.cpp
@@ -143,12 +143,13 @@ void Scope::add_crayPointer(const SourceName &name, Symbol &pointer) {
crayPointers_.emplace(name, pointer);
}
-Symbol &Scope::MakeCommonBlock(const SourceName &name) {
+Symbol &Scope::MakeCommonBlock(SourceName name, SourceName location) {
const auto it{commonBlocks_.find(name)};
if (it != commonBlocks_.end()) {
return *it->second;
} else {
- Symbol &symbol{MakeSymbol(name, Attrs{}, CommonBlockDetails{})};
+ Symbol &symbol{MakeSymbol(
+ name, Attrs{}, CommonBlockDetails{name.empty() ? location : name})};
commonBlocks_.emplace(name, symbol);
return symbol;
}
diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp
index 6db11aaf56c2a..bdb5377265c14 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -313,15 +313,13 @@ class CommonBlockMap {
/// Return the symbol of an initialized member if a COMMON block
/// is initalized. Otherwise, return nullptr.
static Symbol *CommonBlockIsInitialized(const Symbol &common) {
- const auto &commonDetails =
- common.get<Fortran::semantics::CommonBlockDetails>();
-
+ const auto &commonDetails{
+ common.get<Fortran::semantics::CommonBlockDetails>()};
fo...
[truncated]
|
eugeneepshteyn
approved these changes
Sep 30, 2025
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
COMMON block checks are split between name resolution and declaration checking. We generally want declaration checks to take place after name resolution, and the COMMON block checks that are currently in name resolution have some derived type analyses that are redundant with the derived type component iteration framework used elsewhere in semantics. So move as much as possible into declaration checking, use the component iteration framework, and cope with the missing COMMON block name case that arises with blank COMMON when placing the error messages.