From faae05de30db55a72573189eaa5027e728319654 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Mon, 29 Sep 2025 14:53:09 -0700 Subject: [PATCH] [flang] Consolidate & clean up COMMON block checks 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. --- flang/include/flang/Parser/parse-tree.h | 1 + flang/include/flang/Semantics/scope.h | 2 +- flang/include/flang/Semantics/symbol.h | 6 +- flang/include/flang/Semantics/type.h | 3 + flang/lib/Evaluate/tools.cpp | 9 ++ flang/lib/Parser/Fortran-parsers.cpp | 4 +- flang/lib/Semantics/check-declarations.cpp | 126 ++++++++++++++++----- flang/lib/Semantics/resolve-directives.cpp | 2 +- flang/lib/Semantics/resolve-names.cpp | 101 +++-------------- flang/lib/Semantics/scope.cpp | 5 +- flang/lib/Semantics/semantics.cpp | 6 +- flang/lib/Semantics/type.cpp | 23 +++- flang/test/Semantics/declarations01.f90 | 2 +- flang/test/Semantics/declarations08.f90 | 2 +- flang/test/Semantics/resolve42.f90 | 38 +++++-- 15 files changed, 186 insertions(+), 144 deletions(-) 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 &&, std::list &&, std::list &&); + CharBlock source; std::list 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 // 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()}) { + 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(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("COMMON" >> defaulted("/" >> maybe(name) / "/"), nonemptyList("expected COMMON block objects"_err_en_US, Parser{}), many(maybe(","_tok) >> construct("/" >> maybe(name) / "/", nonemptyList("expected COMMON block objects"_err_en_US, - Parser{}))))) + Parser{})))))) // R874 common-block-object -> variable-name [( array-spec )] TYPE_PARSER(construct(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()}; + 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().objects()) { - if (ref->has()) { - 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().objects()) { + auto restorer{ + messages_.SetLocation(location.empty() ? ref->name() : location)}; + if (isBindCCommon && ref->has()) { + 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().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 { for (const parser::OmpObject &obj : x.v) { auto *name{std::get_if(&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 &); - Symbol &MakeCommonBlockSymbol(const parser::Name &); - Symbol &MakeCommonBlockSymbol(const std::optional &); + Symbol &MakeCommonBlockSymbol(const parser::Name &, SourceName); + Symbol &MakeCommonBlockSymbol( + const std::optional &, 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 &, 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(y.t)}; const auto &name{std::get(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().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 &name) { + const std::optional &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()}; - 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(object.t))}; if (auto *details{obj.detailsIf()}) { 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(); - + const auto &commonDetails{ + common.get()}; 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().isForwardReferenced(); } -bool DerivedTypeSpec::HasDefaultInitialization( +std::optional 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