diff --git a/flang/include/flang/Parser/tools.h b/flang/include/flang/Parser/tools.h
--- a/flang/include/flang/Parser/tools.h
+++ b/flang/include/flang/Parser/tools.h
@@ -74,6 +74,15 @@
}
}
+ 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
--- a/flang/include/flang/Semantics/symbol.h
+++ b/flang/include/flang/Semantics/symbol.h
@@ -386,6 +386,8 @@
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 @@
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 @@
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
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -100,6 +100,7 @@
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
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -61,6 +61,7 @@
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 @@
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::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
--- a/flang/lib/Semantics/compute-offsets.cpp
+++ b/flang/lib/Semantics/compute-offsets.cpp
@@ -81,11 +81,6 @@
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
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -680,7 +680,10 @@
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
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -68,8 +68,8 @@
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,17 @@
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 isImplicitNoneExternal() const {
- return implicitRules().isImplicitNoneExternal();
+ return implicitRules_->isImplicitNoneExternal();
+ }
+ void set_inheritFromParent(bool x) {
+ implicitRules_->set_inheritFromParent(x);
}
protected:
@@ -452,6 +456,8 @@
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 +589,8 @@
const DeclTypeSpec &MakeLogicalType(
const std::optional<parser::KindSelector> &);
+ bool inExecutionPart_{false};
+
private:
Scope *currScope_{nullptr};
};
@@ -689,7 +697,6 @@
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 +806,6 @@
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 +826,7 @@
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 +838,8 @@
// 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 +877,8 @@
} 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 +909,6 @@
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 +922,25 @@
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 +963,17 @@
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 +1347,7 @@
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 +1386,14 @@
}
}
-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 +1699,7 @@
"IMPLICIT NONE(TYPE) statement"_err_en_US);
return false;
}
- implicitRules().set_isImplicitNoneType(false);
+ implicitRules_->set_isImplicitNoneType(false);
return true;
},
},
@@ -1704,7 +1719,7 @@
return false;
}
}
- implicitRules().SetTypeMapping(*GetDeclTypeSpec(), loLoc, hiLoc);
+ implicitRules_->SetTypeMapping(*GetDeclTypeSpec(), loLoc, hiLoc);
return false;
}
@@ -1749,7 +1764,7 @@
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 +1776,13 @@
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 +1930,22 @@
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 +2105,8 @@
}
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 +3016,7 @@
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 +3122,10 @@
}
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 &) {
@@ -4210,44 +4232,23 @@
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) {
@@ -4408,7 +4409,7 @@
}
}
// 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;
@@ -4442,12 +4443,20 @@
}
}
}
- 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);
@@ -4823,8 +4832,7 @@
}
name.symbol = nullptr;
}
- auto &symbol{DeclareObjectEntity(name, {})};
-
+ auto &symbol{DeclareObjectEntity(name)};
if (symbol.GetType()) {
// type came from explicit type-spec
} else if (!prev) {
@@ -5418,10 +5426,15 @@
// 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) ||
@@ -5448,6 +5461,44 @@
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) {
+ 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())) {
@@ -5896,13 +5947,14 @@
}
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)}) {
@@ -5919,17 +5971,19 @@
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 &) {},
@@ -5937,6 +5991,21 @@
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
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1305,4 +1305,9 @@
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
--- a/flang/test/Semantics/block-data01.f90
+++ b/flang/test/Semantics/block-data01.f90
@@ -7,9 +7,10 @@
!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
--- /dev/null
+++ b/flang/test/Semantics/implicit11.f90
@@ -0,0 +1,52 @@
+! 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
+
diff --git a/flang/test/Semantics/modfile21.f90 b/flang/test/Semantics/modfile21.f90
--- a/flang/test/Semantics/modfile21.f90
+++ b/flang/test/Semantics/modfile21.f90
@@ -26,10 +26,10 @@
! 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
--- a/flang/test/Semantics/resolve42.f90
+++ b/flang/test/Semantics/resolve42.f90
@@ -11,11 +11,11 @@
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