[flang-commits] [flang] b8bfe35 - [flang] Fix bug accessing implicit variable in specification expression
Tim Keith via flang-commits
flang-commits at lists.llvm.org
Mon Aug 24 12:54:01 PDT 2020
Author: Tim Keith
Date: 2020-08-24T12:53:46-07:00
New Revision: b8bfe3586eb892951b79eb70f8af758a318db861
URL: https://github.com/llvm/llvm-project/commit/b8bfe3586eb892951b79eb70f8af758a318db861
DIFF: https://github.com/llvm/llvm-project/commit/b8bfe3586eb892951b79eb70f8af758a318db861.diff
LOG: [flang] Fix bug accessing implicit variable in specification expression
A specification expression can reference an implicitly declared variable
in the host procedure. Because we have to process specification parts
before execution parts, this may be the first time we encounter the
variable. We were assuming the variable was implicitly declared in the
scope where it was encountered, leading to an error because local
variables may not be referenced in specification expressions.
The fix is to tentatively create the implicit variable in the host
procedure because that is the only way the specification expression can
be valid. We mark it with the flag `ImplicitOrError` to indicate that
either it must be implicitly defined in the host (by being mentioned in
the execution part) or else its use turned out to be an error.
We need to apply the implicit type rules of the host, which requires
some changes to implicit typing.
Variables in common blocks are allowed to appear in specification expressions
(because they are not locals) but the common block definition may not appear
until after their use. To handle this we create common block symbols and object
entities for each common block object during the `PreSpecificationConstruct`
pass. This allows us to remove the corresponding code in the main visitor and
`commonBlockInfo_.curr`. The change in order of processing causes some
different error messages to be emitted.
Some cleanup is included with this change:
- In `ExpressionAnalyzer`, if an unresolved name is encountered but
no error has been reported, emit an internal error.
- Change `ImplicitRulesVisitor` to hide the `ImplicitRules` object
that implements it. Change the interface to pass in names rather
than having to get the first character of the name.
- Change `DeclareObjectEntity` to have the `attrs` argument default
to an empty set; that is the typical case.
- In `Pre(parser::SpecificationPart)` use "structured bindings" to
give names to the pieces that make up a specification-part.
- Enhance `parser::Unwrap` to unwrap `Statement` and `UnlabeledStatement`
and make use of that in PreSpecificationConstruct.
Differential Revision: https://reviews.llvm.org/D86322
Added:
flang/test/Semantics/implicit11.f90
Modified:
flang/include/flang/Parser/tools.h
flang/include/flang/Semantics/symbol.h
flang/include/flang/Semantics/tools.h
flang/lib/Semantics/check-declarations.cpp
flang/lib/Semantics/compute-offsets.cpp
flang/lib/Semantics/expression.cpp
flang/lib/Semantics/resolve-names.cpp
flang/lib/Semantics/tools.cpp
flang/test/Semantics/block-data01.f90
flang/test/Semantics/modfile21.f90
flang/test/Semantics/resolve42.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Parser/tools.h b/flang/include/flang/Parser/tools.h
index fa6ecd08a318..66c8793399c9 100644
--- a/flang/include/flang/Parser/tools.h
+++ b/flang/include/flang/Parser/tools.h
@@ -74,6 +74,15 @@ struct UnwrapperHelper {
}
}
+ template <typename A, typename B>
+ static const A *Unwrap(const UnlabeledStatement<B> &x) {
+ return Unwrap<A>(x.statement);
+ }
+ template <typename A, typename B>
+ static const A *Unwrap(const Statement<B> &x) {
+ return Unwrap<A>(x.statement);
+ }
+
template <typename A, typename B> static const A *Unwrap(B &x) {
if constexpr (std::is_same_v<std::decay_t<A>, std::decay_t<B>>) {
return &x;
diff --git a/flang/include/flang/Semantics/symbol.h b/flang/include/flang/Semantics/symbol.h
index c0a50364b63d..15732e0c6837 100644
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -386,6 +386,8 @@ class HostAssocDetails {
public:
HostAssocDetails(const Symbol &symbol) : symbol_{symbol} {}
const Symbol &symbol() const { return symbol_; }
+ bool implicitOrSpecExprError{false};
+ bool implicitOrExplicitTypeError{false};
private:
SymbolRef symbol_;
@@ -481,6 +483,7 @@ class Symbol {
Subroutine, // symbol is a subroutine
StmtFunction, // symbol is a statement function (Function is set too)
Implicit, // symbol is implicitly typed
+ ImplicitOrError, // symbol must be implicitly typed or it's an error
ModFile, // symbol came from .mod file
ParentComp, // symbol is the "parent component" of an extended type
CrayPointer, CrayPointee,
@@ -488,14 +491,12 @@ class Symbol {
LocalityLocalInit, // named in LOCAL_INIT locality-spec
LocalityShared, // named in SHARED locality-spec
InDataStmt, // initialized in a DATA statement
-
// OpenACC data-sharing attribute
AccPrivate, AccFirstPrivate, AccShared,
// OpenACC data-mapping attribute
AccCopyIn, AccCopyOut, AccCreate, AccDelete, AccPresent,
// OpenACC miscellaneous flags
AccCommonBlock, AccThreadPrivate, AccReduction, AccNone, AccPreDetermined,
-
// OpenMP data-sharing attribute
OmpShared, OmpPrivate, OmpLinear, OmpFirstPrivate, OmpLastPrivate,
// OpenMP data-mapping attribute
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index f63e4ccbc687..adc722c3847f 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -100,6 +100,7 @@ bool HasIntrinsicTypeName(const Symbol &);
bool IsSeparateModuleProcedureInterface(const Symbol *);
bool IsAutomatic(const Symbol &);
bool HasAlternateReturns(const Symbol &);
+bool InCommonBlock(const Symbol &);
// Return an ultimate component of type that matches predicate, or nullptr.
const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 4e91235938e6..d5fa7b9ab370 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -61,6 +61,7 @@ class CheckHelper {
void CheckSubprogram(const Symbol &, const SubprogramDetails &);
void CheckAssumedTypeEntity(const Symbol &, const ObjectEntityDetails &);
void CheckDerivedType(const Symbol &, const DerivedTypeDetails &);
+ void CheckHostAssoc(const Symbol &, const HostAssocDetails &);
void CheckGeneric(const Symbol &, const GenericDetails &);
std::optional<std::vector<Procedure>> Characterize(const SymbolVector &);
bool CheckDefinedOperator(const SourceName &, const GenericKind &,
@@ -147,7 +148,10 @@ void CheckHelper::Check(const Symbol &symbol) {
CheckVolatile(symbol, isAssociated, derived);
}
if (isAssociated) {
- return; // only care about checking VOLATILE on associated symbols
+ if (const auto *details{symbol.detailsIf<HostAssocDetails>()}) {
+ CheckHostAssoc(symbol, *details);
+ }
+ return; // no other checks on associated symbols
}
if (IsPointer(symbol)) {
CheckPointer(symbol);
@@ -758,6 +762,21 @@ void CheckHelper::CheckDerivedType(
}
}
+void CheckHelper::CheckHostAssoc(
+ const Symbol &symbol, const HostAssocDetails &details) {
+ const Symbol &hostSymbol{details.symbol()};
+ if (hostSymbol.test(Symbol::Flag::ImplicitOrError)) {
+ if (details.implicitOrSpecExprError) {
+ messages_.Say("Implicitly typed local entity '%s' not allowed in"
+ " specification expression"_err_en_US,
+ symbol.name());
+ } else if (details.implicitOrExplicitTypeError) {
+ messages_.Say(
+ "No explicit type declared for '%s'"_err_en_US, symbol.name());
+ }
+ }
+}
+
void CheckHelper::CheckGeneric(
const Symbol &symbol, const GenericDetails &details) {
const SymbolVector &specifics{details.specificProcs()};
diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp
index 8d90bf99fe27..a927f094afa8 100644
--- a/flang/lib/Semantics/compute-offsets.cpp
+++ b/flang/lib/Semantics/compute-offsets.cpp
@@ -81,11 +81,6 @@ void ComputeOffsetsHelper::Compute(Scope &scope) {
equivalenceBlock_.clear();
}
-static bool InCommonBlock(const Symbol &symbol) {
- const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
- return details && details->commonBlock();
-}
-
void ComputeOffsetsHelper::DoScope(Scope &scope) {
if (scope.symbol() && scope.IsParameterizedDerivedType()) {
return; // only process instantiations of parameterized derived types
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index cfb908179c3a..747c663255d6 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -680,7 +680,10 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Name &n) {
if (std::optional<int> kind{IsImpliedDo(n.source)}) {
return AsMaybeExpr(ConvertToKind<TypeCategory::Integer>(
*kind, AsExpr(ImpliedDoIndex{n.source})));
- } else if (context_.HasError(n) || !n.symbol) {
+ } else if (context_.HasError(n)) {
+ return std::nullopt;
+ } else if (!n.symbol) {
+ SayAt(n, "Internal error: unresolved name '%s'"_err_en_US, n.source);
return std::nullopt;
} else {
const Symbol &ultimate{n.symbol->GetUltimate()};
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 7feca5b00a8f..60376a1b8469 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -68,8 +68,8 @@ class ImplicitRules {
void set_isImplicitNoneType(bool x) { isImplicitNoneType_ = x; }
void set_isImplicitNoneExternal(bool x) { isImplicitNoneExternal_ = x; }
void set_inheritFromParent(bool x) { inheritFromParent_ = x; }
- // Get the implicit type for identifiers starting with ch. May be null.
- const DeclTypeSpec *GetType(char ch) const;
+ // Get the implicit type for this name. May be null.
+ const DeclTypeSpec *GetType(SourceName) const;
// Record the implicit type for the range of characters [fromLetter,
// toLetter].
void SetTypeMapping(const DeclTypeSpec &type, parser::Location fromLetter,
@@ -385,13 +385,20 @@ class ImplicitRulesVisitor : public DeclTypeSpecVisitor {
bool Pre(const parser::ImplicitSpec &);
void Post(const parser::ImplicitSpec &);
- ImplicitRules &implicitRules() { return *implicitRules_; }
- const ImplicitRules &implicitRules() const { return *implicitRules_; }
+ const DeclTypeSpec *GetType(SourceName name) {
+ return implicitRules_->GetType(name);
+ }
bool isImplicitNoneType() const {
- return implicitRules().isImplicitNoneType();
+ return implicitRules_->isImplicitNoneType();
+ }
+ bool isImplicitNoneType(const Scope &scope) const {
+ return implicitRulesMap_->at(&scope).isImplicitNoneType();
}
bool isImplicitNoneExternal() const {
- return implicitRules().isImplicitNoneExternal();
+ return implicitRules_->isImplicitNoneExternal();
+ }
+ void set_inheritFromParent(bool x) {
+ implicitRules_->set_inheritFromParent(x);
}
protected:
@@ -452,6 +459,8 @@ class ScopeHandler : public ImplicitRulesVisitor {
using ImplicitRulesVisitor::Pre;
Scope &currScope() { return DEREF(currScope_); }
+ // The enclosing host procedure if current scope is in an internal procedure
+ Scope *GetHostProcedure();
// The enclosing scope, skipping blocks and derived types.
// TODO: Will return the scope of a FORALL or implied DO loop; is this ok?
// If not, should call FindProgramUnitContaining() instead.
@@ -583,6 +592,8 @@ class ScopeHandler : public ImplicitRulesVisitor {
const DeclTypeSpec &MakeLogicalType(
const std::optional<parser::KindSelector> &);
+ bool inExecutionPart_{false};
+
private:
Scope *currScope_{nullptr};
};
@@ -689,7 +700,6 @@ class SubprogramVisitor : public virtual ScopeHandler, public InterfaceVisitor {
protected:
// Set when we see a stmt function that is really an array element assignment
bool badStmtFuncFound_{false};
- bool inExecutionPart_{false};
private:
// Info about the current function: parse tree of the type in the PrefixSpec;
@@ -799,7 +809,6 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool Pre(const parser::NamelistStmt::Group &);
bool Pre(const parser::IoControlSpec &);
bool Pre(const parser::CommonStmt::Block &);
- void Post(const parser::CommonStmt::Block &);
bool Pre(const parser::CommonBlockObject &);
void Post(const parser::CommonBlockObject &);
bool Pre(const parser::EquivalenceStmt &);
@@ -820,7 +829,7 @@ class DeclarationVisitor : public ArraySpecVisitor,
protected:
bool BeginDecl();
void EndDecl();
- Symbol &DeclareObjectEntity(const parser::Name &, Attrs);
+ Symbol &DeclareObjectEntity(const parser::Name &, Attrs = Attrs{});
// Make sure that there's an entity in an enclosing scope called Name
Symbol &FindOrDeclareEnclosingEntity(const parser::Name &);
// Declare a LOCAL/LOCAL_INIT entity. If there isn't a type specified
@@ -832,6 +841,8 @@ class DeclarationVisitor : public ArraySpecVisitor,
// Return pointer to the new symbol, or nullptr on error.
Symbol *DeclareStatementEntity(
const parser::Name &, const std::optional<parser::IntegerTypeSpec> &);
+ Symbol &MakeCommonBlockSymbol(const parser::Name &);
+ Symbol &MakeCommonBlockSymbol(const std::optional<parser::Name> &);
bool CheckUseError(const parser::Name &);
void CheckAccessibility(const SourceName &, bool, Symbol &);
void CheckCommonBlocks();
@@ -869,11 +880,8 @@ class DeclarationVisitor : public ArraySpecVisitor,
} derivedTypeInfo_;
// Collect equivalence sets and process at end of specification part
std::vector<const std::list<parser::EquivalenceObject> *> equivalenceSets_;
- // Info about common blocks in the current scope
- struct {
- Symbol *curr{nullptr}; // common block currently being processed
- std::set<SourceName> names; // names in any common block of scope
- } commonBlockInfo_;
+ // Names of all common block objects in the scope
+ std::set<SourceName> commonBlockObjects_;
// Info about about SAVE statements and attributes in current scope
struct {
std::optional<SourceName> saveAll; // "SAVE" without entity list
@@ -904,7 +912,6 @@ class DeclarationVisitor : public ArraySpecVisitor,
bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr);
ParamValue GetParamValue(
const parser::TypeParamValue &, common::TypeParamAttr attr);
- Symbol &MakeCommonBlockSymbol(const parser::Name &);
void CheckCommonBlockDerivedType(const SourceName &, const Symbol &);
std::optional<MessageFixedText> CheckSaveAttr(const Symbol &);
Attrs HandleSaveName(const SourceName &, Attrs);
@@ -918,22 +925,25 @@ class DeclarationVisitor : public ArraySpecVisitor,
void Initialization(const parser::Name &, const parser::Initialization &,
bool inComponentDecl);
bool PassesLocalityChecks(const parser::Name &name, Symbol &symbol);
+ bool CheckForHostAssociatedImplicit(const parser::Name &);
// Declare an object or procedure entity.
// T is one of: EntityDetails, ObjectEntityDetails, ProcEntityDetails
template <typename T>
Symbol &DeclareEntity(const parser::Name &name, Attrs attrs) {
Symbol &symbol{MakeSymbol(name, attrs)};
- if (symbol.has<T>()) {
- // OK
+ if (context().HasError(symbol) || symbol.has<T>()) {
+ return symbol; // OK or error already reported
} else if (symbol.has<UnknownDetails>()) {
symbol.set_details(T{});
+ return symbol;
} else if (auto *details{symbol.detailsIf<EntityDetails>()}) {
symbol.set_details(T{std::move(*details)});
+ return symbol;
} else if (std::is_same_v<EntityDetails, T> &&
(symbol.has<ObjectEntityDetails>() ||
symbol.has<ProcEntityDetails>())) {
- // OK
+ return symbol; // OK
} else if (auto *details{symbol.detailsIf<UseDetails>()}) {
Say(name.source,
"'%s' is use-associated from module '%s' and cannot be re-declared"_err_en_US,
@@ -956,11 +966,17 @@ class DeclarationVisitor : public ArraySpecVisitor,
name, symbol, "'%s' is already declared as a procedure"_err_en_US);
} else if (std::is_same_v<ProcEntityDetails, T> &&
symbol.has<ObjectEntityDetails>()) {
- SayWithDecl(
- name, symbol, "'%s' is already declared as an object"_err_en_US);
+ if (InCommonBlock(symbol)) {
+ SayWithDecl(name, symbol,
+ "'%s' may not be a procedure as it is in a COMMON block"_err_en_US);
+ } else {
+ SayWithDecl(
+ name, symbol, "'%s' is already declared as an object"_err_en_US);
+ }
} else {
SayAlreadyDeclared(name, symbol);
}
+ context().SetError(symbol);
return symbol;
}
};
@@ -1334,6 +1350,7 @@ class ResolveNamesVisitor : public virtual ScopeHandler,
std::optional<SourceName> prevImportStmt_;
void PreSpecificationConstruct(const parser::SpecificationConstruct &);
+ void CreateCommonBlockSymbols(const parser::CommonStmt &);
void CreateGeneric(const parser::GenericSpec &);
void FinishSpecificationPart(const std::list<parser::DeclarationConstruct> &);
void AnalyzeStmtFunctionStmt(const parser::StmtFunctionStmt &);
@@ -1372,13 +1389,14 @@ bool ImplicitRules::isImplicitNoneExternal() const {
}
}
-const DeclTypeSpec *ImplicitRules::GetType(char ch) const {
+const DeclTypeSpec *ImplicitRules::GetType(SourceName name) const {
+ char ch{name.begin()[0]};
if (isImplicitNoneType_) {
return nullptr;
} else if (auto it{map_.find(ch)}; it != map_.end()) {
return &*it->second;
} else if (inheritFromParent_) {
- return parent_->GetType(ch);
+ return parent_->GetType(name);
} else if (ch >= 'i' && ch <= 'n') {
return &context_.MakeNumericType(TypeCategory::Integer);
} else if (ch >= 'a' && ch <= 'z') {
@@ -1684,7 +1702,7 @@ bool ImplicitRulesVisitor::Pre(const parser::ImplicitStmt &x) {
"IMPLICIT NONE(TYPE) statement"_err_en_US);
return false;
}
- implicitRules().set_isImplicitNoneType(false);
+ implicitRules_->set_isImplicitNoneType(false);
return true;
},
},
@@ -1704,7 +1722,7 @@ bool ImplicitRulesVisitor::Pre(const parser::LetterSpec &x) {
return false;
}
}
- implicitRules().SetTypeMapping(*GetDeclTypeSpec(), loLoc, hiLoc);
+ implicitRules_->SetTypeMapping(*GetDeclTypeSpec(), loLoc, hiLoc);
return false;
}
@@ -1749,7 +1767,7 @@ bool ImplicitRulesVisitor::HandleImplicitNone(
if (nameSpecs.empty()) {
if (!implicitNoneTypeNever) {
prevImplicitNoneType_ = currStmtSource();
- implicitRules().set_isImplicitNoneType(true);
+ implicitRules_->set_isImplicitNoneType(true);
if (prevImplicit_) {
Say("IMPLICIT NONE statement after IMPLICIT statement"_err_en_US);
return false;
@@ -1761,13 +1779,13 @@ bool ImplicitRulesVisitor::HandleImplicitNone(
for (const auto noneSpec : nameSpecs) {
switch (noneSpec) {
case ImplicitNoneNameSpec::External:
- implicitRules().set_isImplicitNoneExternal(true);
+ implicitRules_->set_isImplicitNoneExternal(true);
++sawExternal;
break;
case ImplicitNoneNameSpec::Type:
if (!implicitNoneTypeNever) {
prevImplicitNoneType_ = currStmtSource();
- implicitRules().set_isImplicitNoneType(true);
+ implicitRules_->set_isImplicitNoneType(true);
if (prevImplicit_) {
Say("IMPLICIT NONE(TYPE) after IMPLICIT statement"_err_en_US);
return false;
@@ -1915,14 +1933,22 @@ void ScopeHandler::Say2(const parser::Name &name, MessageFixedText &&msg1,
context().SetError(symbol, msg1.isFatal());
}
-Scope &ScopeHandler::InclusiveScope() {
- for (auto *scope{&currScope()};; scope = &scope->parent()) {
- if (scope->kind() != Scope::Kind::Block && !scope->IsDerivedType() &&
- !scope->IsStmtFunction()) {
- return *scope;
+// T may be `Scope` or `const Scope`
+template <typename T> static T &GetInclusiveScope(T &scope) {
+ for (T *s{&scope}; !s->IsGlobal(); s = &s->parent()) {
+ if (s->kind() != Scope::Kind::Block && !s->IsDerivedType() &&
+ !s->IsStmtFunction()) {
+ return *s;
}
}
- DIE("inclusive scope not found");
+ return scope;
+}
+
+Scope &ScopeHandler::InclusiveScope() { return GetInclusiveScope(currScope()); }
+
+Scope *ScopeHandler::GetHostProcedure() {
+ Scope &parent{InclusiveScope().parent()};
+ return parent.kind() == Scope::Kind::Subprogram ? &parent : nullptr;
}
Scope &ScopeHandler::NonDerivedTypeScope() {
@@ -2082,7 +2108,8 @@ void ScopeHandler::ApplyImplicitRules(Symbol &symbol) {
}
const DeclTypeSpec *ScopeHandler::GetImplicitType(Symbol &symbol) {
- const DeclTypeSpec *type{implicitRules().GetType(symbol.name().begin()[0])};
+ const auto *type{implicitRulesMap_->at(&GetInclusiveScope(symbol.owner()))
+ .GetType(symbol.name())};
if (type) {
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
// Resolve any forward-referenced derived type; a quick no-op else.
@@ -2992,7 +3019,7 @@ Symbol &SubprogramVisitor::PushSubprogramScope(
if (isGeneric()) {
GetGenericDetails().AddSpecificProc(*symbol, name.source);
}
- implicitRules().set_inheritFromParent(false);
+ set_inheritFromParent(false);
}
FindSymbol(name)->set(subpFlag); // PushScope() created symbol
return *symbol;
@@ -3098,12 +3125,10 @@ void DeclarationVisitor::Post(const parser::TypeDeclarationStmt &) {
}
void DeclarationVisitor::Post(const parser::DimensionStmt::Declaration &x) {
- const auto &name{std::get<parser::Name>(x.t)};
- DeclareObjectEntity(name, Attrs{});
+ DeclareObjectEntity(std::get<parser::Name>(x.t));
}
void DeclarationVisitor::Post(const parser::CodimensionDecl &x) {
- const auto &name{std::get<parser::Name>(x.t)};
- DeclareObjectEntity(name, Attrs{});
+ DeclareObjectEntity(std::get<parser::Name>(x.t));
}
bool DeclarationVisitor::Pre(const parser::Initialization &) {
@@ -4211,44 +4236,23 @@ bool DeclarationVisitor::Pre(const parser::IoControlSpec &x) {
bool DeclarationVisitor::Pre(const parser::CommonStmt::Block &x) {
CheckNotInBlock("COMMON"); // C1107
- const auto &optName{std::get<std::optional<parser::Name>>(x.t)};
- parser::Name blankCommon;
- blankCommon.source =
- SourceName{currStmtSource().value().begin(), std::size_t{0}};
- CHECK(!commonBlockInfo_.curr);
- commonBlockInfo_.curr =
- &MakeCommonBlockSymbol(optName ? *optName : blankCommon);
return true;
}
-void DeclarationVisitor::Post(const parser::CommonStmt::Block &) {
- commonBlockInfo_.curr = nullptr;
-}
-
bool DeclarationVisitor::Pre(const parser::CommonBlockObject &) {
BeginArraySpec();
return true;
}
void DeclarationVisitor::Post(const parser::CommonBlockObject &x) {
- CHECK(commonBlockInfo_.curr);
const auto &name{std::get<parser::Name>(x.t)};
- auto &symbol{DeclareObjectEntity(name, Attrs{})};
- ClearArraySpec();
- ClearCoarraySpec();
- auto *details{symbol.detailsIf<ObjectEntityDetails>()};
- if (!details) {
- return; // error was reported
- }
- commonBlockInfo_.curr->get<CommonBlockDetails>().add_object(symbol);
- auto pair{commonBlockInfo_.names.insert(name.source)};
+ DeclareObjectEntity(name);
+ auto pair{commonBlockObjects_.insert(name.source)};
if (!pair.second) {
const SourceName &prev{*pair.first};
Say2(name.source, "'%s' is already in a COMMON block"_err_en_US, prev,
"Previous occurrence of '%s' in a COMMON block"_en_US);
- return;
}
- details->set_commonBlock(*commonBlockInfo_.curr);
}
bool DeclarationVisitor::Pre(const parser::EquivalenceStmt &x) {
@@ -4409,7 +4413,7 @@ void DeclarationVisitor::CheckCommonBlocks() {
}
}
// check objects in common blocks
- for (const auto &name : commonBlockInfo_.names) {
+ for (const auto &name : commonBlockObjects_) {
const auto *symbol{currScope().FindSymbol(name)};
if (!symbol) {
continue;
@@ -4443,12 +4447,20 @@ void DeclarationVisitor::CheckCommonBlocks() {
}
}
}
- commonBlockInfo_ = {};
+ commonBlockObjects_ = {};
}
Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) {
return Resolve(name, currScope().MakeCommonBlock(name.source));
}
+Symbol &DeclarationVisitor::MakeCommonBlockSymbol(
+ const std::optional<parser::Name> &name) {
+ if (name) {
+ return MakeCommonBlockSymbol(*name);
+ } else {
+ return MakeCommonBlockSymbol(parser::Name{});
+ }
+}
bool DeclarationVisitor::NameIsKnownOrIntrinsic(const parser::Name &name) {
return FindSymbol(name) || HandleUnrestrictedSpecificIntrinsicFunction(name);
@@ -4824,8 +4836,7 @@ void ConstructVisitor::ResolveIndexName(
}
name.symbol = nullptr;
}
- auto &symbol{DeclareObjectEntity(name, {})};
-
+ auto &symbol{DeclareObjectEntity(name)};
if (symbol.GetType()) {
// type came from explicit type-spec
} else if (!prev) {
@@ -5419,10 +5430,15 @@ const parser::Name *DeclarationVisitor::ResolveDataRef(
// If implicit types are allowed, ensure name is in the symbol table.
// Otherwise, report an error if it hasn't been declared.
const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
- if (Symbol * symbol{FindSymbol(name)}) {
+ FindSymbol(name);
+ if (CheckForHostAssociatedImplicit(name)) {
+ return &name;
+ }
+ if (Symbol * symbol{name.symbol}) {
if (CheckUseError(name)) {
return nullptr; // reported an error
}
+ symbol->set(Symbol::Flag::ImplicitOrError, false);
if (IsUplevelReference(*symbol)) {
MakeHostAssocSymbol(name, *symbol);
} else if (IsDummy(*symbol) ||
@@ -5449,6 +5465,44 @@ const parser::Name *DeclarationVisitor::ResolveName(const parser::Name &name) {
return &name;
}
+// A specification expression may refer to a symbol in the host procedure that
+// is implicitly typed. Because specification parts are processed before
+// execution parts, this may be the first time we see the symbol. It can't be a
+// local in the current scope (because it's in a specification expression) so
+// either it is implicitly declared in the host procedure or it is an error.
+// We create a symbol in the host assuming it is the former; if that proves to
+// be wrong we report an error later in CheckDeclarations().
+bool DeclarationVisitor::CheckForHostAssociatedImplicit(
+ const parser::Name &name) {
+ if (inExecutionPart_) {
+ return false;
+ }
+ if (name.symbol) {
+ ApplyImplicitRules(*name.symbol);
+ }
+ Symbol *hostSymbol;
+ Scope *host{GetHostProcedure()};
+ if (!host || isImplicitNoneType(*host)) {
+ return false;
+ } else if (!name.symbol) {
+ hostSymbol = &MakeSymbol(*host, name.source, Attrs{});
+ ConvertToObjectEntity(*hostSymbol);
+ ApplyImplicitRules(*hostSymbol);
+ hostSymbol->set(Symbol::Flag::ImplicitOrError);
+ } else if (name.symbol->test(Symbol::Flag::ImplicitOrError)) {
+ hostSymbol = name.symbol;
+ } else {
+ return false;
+ }
+ Symbol &symbol{MakeHostAssocSymbol(name, *hostSymbol)};
+ if (isImplicitNoneType()) {
+ symbol.get<HostAssocDetails>().implicitOrExplicitTypeError = true;
+ } else {
+ symbol.get<HostAssocDetails>().implicitOrSpecExprError = true;
+ }
+ return true;
+}
+
bool DeclarationVisitor::IsUplevelReference(const Symbol &symbol) {
const Scope *symbolUnit{FindProgramUnitContaining(symbol)};
if (symbolUnit == FindProgramUnitContaining(currScope())) {
@@ -5897,13 +5951,14 @@ static bool NeedsExplicitType(const Symbol &symbol) {
}
bool ResolveNamesVisitor::Pre(const parser::SpecificationPart &x) {
- Walk(std::get<0>(x.t));
- Walk(std::get<1>(x.t));
- Walk(std::get<2>(x.t));
- Walk(std::get<3>(x.t));
- Walk(std::get<4>(x.t));
- Walk(std::get<5>(x.t));
- const std::list<parser::DeclarationConstruct> &decls{std::get<6>(x.t)};
+ const auto &[accDecls, ompDecls, compilerDirectives, useStmts, importStmts,
+ implicitPart, decls] = x.t;
+ Walk(accDecls);
+ Walk(ompDecls);
+ Walk(compilerDirectives);
+ Walk(useStmts);
+ Walk(importStmts);
+ Walk(implicitPart);
for (const auto &decl : decls) {
if (const auto *spec{
std::get_if<parser::SpecificationConstruct>(&decl.u)}) {
@@ -5920,17 +5975,19 @@ void ResolveNamesVisitor::PreSpecificationConstruct(
const parser::SpecificationConstruct &spec) {
std::visit(
common::visitors{
- [&](const Indirection<parser::DerivedTypeDef> &) {},
[&](const parser::Statement<Indirection<parser::GenericStmt>> &y) {
CreateGeneric(std::get<parser::GenericSpec>(y.statement.value().t));
},
[&](const Indirection<parser::InterfaceBlock> &y) {
const auto &stmt{std::get<parser::Statement<parser::InterfaceStmt>>(
y.value().t)};
- const auto *spec{std::get_if<std::optional<parser::GenericSpec>>(
- &stmt.statement.u)};
- if (spec && *spec) {
- CreateGeneric(**spec);
+ if (const auto *spec{parser::Unwrap<parser::GenericSpec>(stmt)}) {
+ CreateGeneric(*spec);
+ }
+ },
+ [&](const parser::Statement<parser::OtherSpecificationStmt> &y) {
+ if (const auto *commonStmt{parser::Unwrap<parser::CommonStmt>(y)}) {
+ CreateCommonBlockSymbols(*commonStmt);
}
},
[&](const auto &) {},
@@ -5938,6 +5995,21 @@ void ResolveNamesVisitor::PreSpecificationConstruct(
spec.u);
}
+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)};
+ for (const auto &object : objects) {
+ Symbol &obj{DeclareObjectEntity(std::get<parser::Name>(object.t))};
+ if (auto *details{obj.detailsIf<ObjectEntityDetails>()}) {
+ details->set_commonBlock(commonBlock);
+ commonBlock.get<CommonBlockDetails>().add_object(obj);
+ }
+ }
+ }
+}
+
void ResolveNamesVisitor::CreateGeneric(const parser::GenericSpec &x) {
auto info{GenericSpecInfo{x}};
const SourceName &symbolName{info.symbolName()};
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index d5ef9c76aa34..cde345af642a 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1305,4 +1305,9 @@ bool HasAlternateReturns(const Symbol &subprogram) {
return false;
}
+bool InCommonBlock(const Symbol &symbol) {
+ const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
+ return details && details->commonBlock();
+}
+
} // namespace Fortran::semantics
diff --git a/flang/test/Semantics/block-data01.f90 b/flang/test/Semantics/block-data01.f90
index 6424824f4606..6549e402cc9d 100644
--- a/flang/test/Semantics/block-data01.f90
+++ b/flang/test/Semantics/block-data01.f90
@@ -7,9 +7,10 @@ block data foo
!ERROR: An initialized variable in BLOCK DATA must be in a COMMON block
integer :: notInCommon = 1
integer :: uninitialized ! ok
- !ERROR: 'p' may not appear in a BLOCK DATA subprogram
+ !ERROR: 'q' may not appear in a BLOCK DATA subprogram
+ procedure(sin), pointer :: q => cos
+ !ERROR: 'p' may not be a procedure as it is in a COMMON block
procedure(sin), pointer :: p => cos
- !ERROR: 'p' is already declared as a procedure
common /block/ pi, p
!ERROR: An initialized variable in BLOCK DATA must be in a COMMON block
integer :: inDataButNotCommon
diff --git a/flang/test/Semantics/implicit11.f90 b/flang/test/Semantics/implicit11.f90
new file mode 100644
index 000000000000..2c8e138de1ef
--- /dev/null
+++ b/flang/test/Semantics/implicit11.f90
@@ -0,0 +1,61 @@
+! RUN: %S/test_errors.sh %s %t %f18
+
+! Test use of implicitly declared variable in specification expression
+
+subroutine s1()
+ m = 1
+contains
+ subroutine s1a()
+ implicit none
+ !ERROR: No explicit type declared for 'n'
+ real :: a(m, n)
+ end
+ subroutine s1b()
+ !ERROR: Implicitly typed local entity 'n' not allowed in specification expression
+ real :: a(m, n)
+ end
+end
+
+subroutine s2()
+ type :: t(m, n)
+ integer, len :: m
+ integer, len :: n
+ end type
+ n = 1
+contains
+ subroutine s2a()
+ !ERROR: Implicitly typed local entity 'm' not allowed in specification expression
+ type(t(m, n)) :: a
+ end
+ subroutine s2b()
+ implicit none
+ !ERROR: No explicit type declared for 'm'
+ character(m) :: a
+ end
+end
+
+subroutine s3()
+ m = 1
+contains
+ subroutine s3a()
+ implicit none
+ real :: a(m, n)
+ !ERROR: No explicit type declared for 'n'
+ common n
+ end
+ subroutine s3b()
+ ! n is okay here because it is in a common block
+ real :: a(m, n)
+ common n
+ end
+end
+
+subroutine s4()
+ implicit none
+contains
+ subroutine s4a()
+ !ERROR: No explicit type declared for 'n'
+ real :: a(n)
+ end
+end
+
diff --git a/flang/test/Semantics/modfile21.f90 b/flang/test/Semantics/modfile21.f90
index f1e4036c96a8..d7b45f70c00d 100644
--- a/flang/test/Semantics/modfile21.f90
+++ b/flang/test/Semantics/modfile21.f90
@@ -26,10 +26,10 @@ module m
! real(4)::v
! complex(4)::w
! real(4)::cb
-! common/cb2/a,b,c
-! bind(c)::/cb2/
! common//t,w,u,v
! common/cb/x,y,z
! bind(c, name="CB")::/cb/
+! common/cb2/a,b,c
+! bind(c)::/cb2/
! common/b/cb
!end
diff --git a/flang/test/Semantics/resolve42.f90 b/flang/test/Semantics/resolve42.f90
index b0b092ae3429..0ae7459ab089 100644
--- a/flang/test/Semantics/resolve42.f90
+++ b/flang/test/Semantics/resolve42.f90
@@ -11,11 +11,11 @@ subroutine s2
end
subroutine s3
+ !ERROR: 'x' may not be a procedure as it is in a COMMON block
procedure(real) :: x
- !ERROR: 'x' is already declared as a procedure
common x
common y
- !ERROR: 'y' is already declared as an object
+ !ERROR: 'y' may not be a procedure as it is in a COMMON block
procedure(real) :: y
end
More information about the flang-commits
mailing list