[flang-commits] [flang] 1fba01a - [flang] Consolidate & clean up COMMON block checks (#161286)
via flang-commits
flang-commits at lists.llvm.org
Fri Oct 3 10:47:53 PDT 2025
Author: Peter Klausler
Date: 2025-10-03T10:47:50-07:00
New Revision: 1fba01a51d6cbf1cc63f4209203babd81950c5e6
URL: https://github.com/llvm/llvm-project/commit/1fba01a51d6cbf1cc63f4209203babd81950c5e6
DIFF: https://github.com/llvm/llvm-project/commit/1fba01a51d6cbf1cc63f4209203babd81950c5e6.diff
LOG: [flang] Consolidate & clean up COMMON block checks (#161286)
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.
Added:
Modified:
flang/include/flang/Parser/parse-tree.h
flang/include/flang/Semantics/scope.h
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/type.h
flang/lib/Evaluate/tools.cpp
flang/lib/Parser/Fortran-parsers.cpp
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/resolve-directives.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/scope.cpp
flang/lib/Semantics/semantics.cpp
flang/lib/Semantics/type.cpp
flang/test/Semantics/declarations01.f90
flang/test/Semantics/declarations08.f90
flang/test/Semantics/resolve42.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Parser/parse-tree.h b/flang/include/flang/Parser/parse-tree.h
index 325ca9b4a227b..1443e93fc4eb0 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 a0d5ae7176141..975423b32da73 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 3cfad03648aee..b927fa3cc7ed7 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 7b881008219df..8a80bf045bcbc 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 02fcf021137ab..18fc63814d973 100644
--- a/flang/lib/Semantics/resolve-directives.cpp
+++ b/flang/lib/Semantics/resolve-directives.cpp
@@ -625,7 +625,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 5041a6a08fc3c..aa09d49f1453b 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -1106,8 +1106,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();
@@ -1244,8 +1245,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 &);
@@ -5564,7 +5563,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)
@@ -7147,7 +7146,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);
@@ -7227,59 +7226,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);
}
}
@@ -7287,43 +7249,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(
@@ -9655,7 +9580,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>()};
for (const auto &member : commonDetails.objects()) {
if (IsInitialized(*member)) {
return &*member;
}
}
-
// Common block may be initialized via initialized variables that are in an
// equivalence with the common block members.
for (const Fortran::semantics::EquivalenceSet &set :
diff --git a/flang/lib/Semantics/type.cpp b/flang/lib/Semantics/type.cpp
index 964a37e1c822b..69e6ffa47d09e 100644
--- a/flang/lib/Semantics/type.cpp
+++ b/flang/lib/Semantics/type.cpp
@@ -206,14 +206,25 @@ bool DerivedTypeSpec::IsForwardReferenced() const {
return typeSymbol_.get<DerivedTypeDetails>().isForwardReferenced();
}
-bool DerivedTypeSpec::HasDefaultInitialization(
+std::optional<std::string> DerivedTypeSpec::ComponentWithDefaultInitialization(
bool ignoreAllocatable, bool ignorePointer) const {
DirectComponentIterator components{*this};
- return bool{std::find_if(
- components.begin(), components.end(), [&](const Symbol &component) {
- return IsInitialized(component, /*ignoreDataStatements=*/true,
- ignoreAllocatable, ignorePointer);
- })};
+ if (auto it{std::find_if(components.begin(), components.end(),
+ [ignoreAllocatable, ignorePointer](const Symbol &component) {
+ return (!ignoreAllocatable && IsAllocatable(component)) ||
+ (!ignorePointer && IsPointer(component)) ||
+ HasDeclarationInitializer(component);
+ })}) {
+ return it.BuildResultDesignatorName();
+ } else {
+ return std::nullopt;
+ }
+}
+
+bool DerivedTypeSpec::HasDefaultInitialization(
+ bool ignoreAllocatable, bool ignorePointer) const {
+ return ComponentWithDefaultInitialization(ignoreAllocatable, ignorePointer)
+ .has_value();
}
bool DerivedTypeSpec::HasDestruction() const {
diff --git a/flang/test/Semantics/declarations01.f90 b/flang/test/Semantics/declarations01.f90
index 77cb6b4f1fef8..3d8754e2bc8fa 100644
--- a/flang/test/Semantics/declarations01.f90
+++ b/flang/test/Semantics/declarations01.f90
@@ -7,7 +7,7 @@ function f1() result(x)
integer, parameter :: x2 = 1
integer :: x3
- !ERROR: A named constant 'x2' may not appear in a COMMON block
+ !ERROR: Named constant 'x2' may not appear in COMMON block /blk/
common /blk/ x2, x3
end
diff --git a/flang/test/Semantics/declarations08.f90 b/flang/test/Semantics/declarations08.f90
index 2c4027d117365..de7d5d75f60e9 100644
--- a/flang/test/Semantics/declarations08.f90
+++ b/flang/test/Semantics/declarations08.f90
@@ -2,7 +2,7 @@
pointer(p,x)
!ERROR: Cray pointee 'y' may not be a member of an EQUIVALENCE group
pointer(p,y)
-!ERROR: Cray pointee 'x' may not be a member of a COMMON block
+!ERROR: Cray pointee 'x' may not be a member of COMMON block //
common x
equivalence(y,z)
!ERROR: Cray pointee 'v' may not be initialized
diff --git a/flang/test/Semantics/resolve42.f90 b/flang/test/Semantics/resolve42.f90
index 5a433d06ccc1d..13caff0b87d85 100644
--- a/flang/test/Semantics/resolve42.f90
+++ b/flang/test/Semantics/resolve42.f90
@@ -28,17 +28,17 @@ subroutine s5
end
function f6(x) result(r)
- !ERROR: ALLOCATABLE object 'y' may not appear in a COMMON block
- !ERROR: Dummy argument 'x' may not appear in a COMMON block
+ !ERROR: ALLOCATABLE object 'y' may not appear in COMMON block //
+ !ERROR: Dummy argument 'x' may not appear in COMMON block //
+ !ERROR: Function result 'r' may not appear in COMMON block //
common y,x,z
allocatable y
- !ERROR: Function result 'r' may not appear in a COMMON block
common r
end
module m7
- !ERROR: Variable 'w' with BIND attribute may not appear in a COMMON block
- !ERROR: Variable 'z' with BIND attribute may not appear in a COMMON block
+ !ERROR: BIND(C) object 'w' may not appear in COMMON block //
+ !ERROR: BIND(C) object 'z' may not appear in COMMON block //
common w,z
integer, bind(c) :: z
integer, bind(c,name="w") :: w
@@ -48,8 +48,8 @@ module m8
type t
end type
class(*), pointer :: x
- !ERROR: Unlimited polymorphic pointer 'x' may not appear in a COMMON block
- !ERROR: Unlimited polymorphic pointer 'y' may not appear in a COMMON block
+ !ERROR: Unlimited polymorphic pointer 'x' may not appear in COMMON block //
+ !ERROR: Unlimited polymorphic pointer 'y' may not appear in COMMON block //
common x, y
class(*), pointer :: y
end
@@ -67,7 +67,7 @@ module m10
type t
end type
type(t) :: x
- !ERROR: Derived type 'x' in COMMON block must have the BIND or SEQUENCE attribute
+ !ERROR: Object 'x' whose derived type 't' is neither SEQUENCE nor BIND(C) may not appear in COMMON block //
common x
end
@@ -82,7 +82,7 @@ module m11
integer:: c
end type
type(t2) :: x2
- !ERROR: Derived type variable 'x2' may not appear in a COMMON block due to ALLOCATABLE component
+ !ERROR: COMMON block /c2/ may not have the member 'x2' whose derived type 't2' has a component '%b%a' that is ALLOCATABLE or has default initialization
common /c2/ x2
end
@@ -97,7 +97,7 @@ module m12
integer:: c
end type
type(t2) :: x2
- !ERROR: Derived type variable 'x2' may not appear in a COMMON block due to component with default initialization
+ !ERROR: COMMON block /c3/ may not have the member 'x2' whose derived type 't2' has a component '%b%a' that is ALLOCATABLE or has default initialization
common /c3/ x2
end
@@ -112,3 +112,21 @@ subroutine s14
!ERROR: 'c' appears as a COMMON block in a BIND statement but not in a COMMON statement
bind(c) :: /c/
end
+
+module m15
+ interface
+ subroutine sub
+ end subroutine
+ end interface
+ type t1
+ sequence
+ procedure(sub), pointer, nopass :: pp => sub
+ end type
+ type t2
+ sequence
+ type(t1) :: a
+ end type
+ type(t2) :: x2
+ !ERROR: COMMON block /c4/ may not have the member 'x2' whose derived type 't2' has a component '%a%pp' that is ALLOCATABLE or has default initialization
+ common /c4/ x2
+end
More information about the flang-commits
mailing list