#include "../evaluate/check-expression.h"
#include "../evaluate/fold.h"
#include "../evaluate/tools.h"
+#include <algorithm>
namespace Fortran::semantics {
bool CheckDefinedAssignmentArg(const Symbol &, const DummyArgument &, int);
void CheckSpecificsAreDistinguishable(
const Symbol &, const GenericDetails &, const std::vector<Procedure> &);
+ void CheckEquivalenceSet(const EquivalenceSet &);
+ void CheckBlockData(const Scope &);
+
void SayNotDistinguishable(
const SourceName &, GenericKind, const Symbol &, const Symbol &);
bool CheckConflicting(const Symbol &, Attr, Attr);
}
}
}
+ if (symbol.owner().kind() != Scope::Kind::DerivedType &&
+ IsInitialized(symbol)) {
+ if (details.commonBlock()) {
+ if (details.commonBlock()->name().empty()) {
+ messages_.Say(
+ "A variable in blank COMMON should not be initialized"_en_US);
+ }
+ } else if (symbol.owner().kind() == Scope::Kind::BlockData) {
+ messages_.Say(
+ "An initialized variable in BLOCK DATA must be in a COMMON block"_err_en_US);
+ }
+ }
}
// The six different kinds of array-specs:
} else if (scope.IsDerivedType()) {
return; // PDT instantiations have null symbol()
}
+ for (const auto &set : scope.equivalenceSets()) {
+ CheckEquivalenceSet(set);
+ }
for (const auto &pair : scope) {
Check(*pair.second);
}
for (const Scope &child : scope.children()) {
Check(child);
}
+ if (scope.kind() == Scope::Kind::BlockData) {
+ CheckBlockData(scope);
+ }
+}
+
+void CheckHelper::CheckEquivalenceSet(const EquivalenceSet &) {
+ // TODO: Move C8106 (&al.) checks here from resolve-names-utils.cc
+}
+
+void CheckHelper::CheckBlockData(const Scope &scope) {
+ // BLOCK DATA subprograms should contain only named common blocks.
+ for (const auto &pair : scope) {
+ const Symbol &symbol{*pair.second};
+ if (!(symbol.has<CommonBlockDetails>() || symbol.has<UseDetails>() ||
+ symbol.has<UseErrorDetails>() || symbol.has<DerivedTypeDetails>() ||
+ symbol.has<SubprogramDetails>() ||
+ symbol.has<ObjectEntityDetails>() ||
+ (symbol.has<ProcEntityDetails>() &&
+ !symbol.attrs().test(Attr::POINTER)))) {
+ messages_.Say(symbol.name(),
+ "'%s' may not appear in a BLOCK DATA subprogram"_err_en_US,
+ symbol.name());
+ }
+ }
}
void CheckDeclarations(SemanticsContext &context) {
namespace Fortran::semantics {
-const Scope *FindContainingSubprogram(const Scope &start) {
- const Scope *scope{&start};
- while (!scope->IsGlobal()) {
- switch (scope->kind()) {
- case Scope::Kind::MainProgram:
- case Scope::Kind::Subprogram: return scope;
- default: scope = &scope->parent(); break;
- }
- }
- return nullptr;
+static const Scope *FindContainingSubprogram(const Scope &start) {
+ const Scope *scope{FindProgramUnitContaining(start)};
+ return scope &&
+ (scope->kind() == Scope::Kind::MainProgram ||
+ scope->kind() == Scope::Kind::Subprogram)
+ ? scope
+ : nullptr;
}
void ReturnStmtChecker::Leave(const parser::ReturnStmt &returnStmt) {
// C1575 The scalar-int-expr is allowed only in the inclusive scope of a
// subroutine subprogram.
const auto &scope{context_.FindScope(context_.location().value())};
- const auto *subprogramScope{FindContainingSubprogram(scope)};
- if (!subprogramScope) {
- context_.Say(
- "RETURN must in the inclusive scope of a SUBPROGRAM"_err_en_US);
- return;
- }
- if (returnStmt.v && subprogramScope->kind() == Scope::Kind::Subprogram) {
- if (IsFunction(*subprogramScope->GetSymbol())) {
- context_.Say(
- "RETURN with expression is only allowed in SUBROUTINE subprogram"_err_en_US);
+ if (const auto *subprogramScope{FindContainingSubprogram(scope)}) {
+ if (returnStmt.v && subprogramScope->kind() == Scope::Kind::Subprogram) {
+ if (IsFunction(*subprogramScope->GetSymbol())) {
+ context_.Say(
+ "RETURN with expression is only allowed in SUBROUTINE subprogram"_err_en_US);
+ }
}
+ } else {
+ context_.Say(
+ "RETURN must be in the inclusive scope of a subprogram"_err_en_US);
}
}
-} // namespace Fortran::semantics
+}
return node;
}
+static ProgramTree BuildSubprogramTree(
+ const parser::Name &name, const parser::BlockData &x) {
+ const auto &spec{std::get<parser::SpecificationPart>(x.t)};
+ return ProgramTree{name, spec, nullptr};
+}
+
template<typename T>
static ProgramTree BuildModuleTree(const parser::Name &name, const T &x) {
const auto &spec{std::get<parser::SpecificationPart>(x.t)};
return BuildModuleTree(name, x).set_stmt(stmt).set_endStmt(end);
}
-ProgramTree ProgramTree::Build(const parser::BlockData &) {
- DIE("BlockData not yet implemented");
+ProgramTree ProgramTree::Build(const parser::BlockData &x) {
+ const auto &stmt{std::get<parser::Statement<parser::BlockDataStmt>>(x.t)};
+ const auto &end{std::get<parser::Statement<parser::EndBlockDataStmt>>(x.t)};
+ static parser::Name emptyName;
+ auto result{stmt.statement.v ? BuildSubprogramTree(*stmt.statement.v, x)
+ : BuildSubprogramTree(emptyName, x)};
+ return result.set_stmt(stmt).set_endStmt(end);
}
const parser::ParentIdentifier &ProgramTree::GetParentId() const {
[](const parser::Statement<parser::SubmoduleStmt> *) {
return Kind::Submodule;
},
+ [](const parser::Statement<parser::BlockDataStmt> *) {
+ return Kind::BlockData;
+ },
},
stmt_);
}
static ProgramTree Build(const parser::BlockData &);
ENUM_CLASS(Kind, // kind of node
- Program, Function, Subroutine, MpSubprogram, Module, Submodule)
+ Program, Function, Subroutine, MpSubprogram, Module, Submodule, BlockData)
using Stmt = std::variant< // the statement that introduces the program unit
const parser::Statement<parser::ProgramStmt> *,
const parser::Statement<parser::FunctionStmt> *,
const parser::Statement<parser::SubroutineStmt> *,
const parser::Statement<parser::MpSubprogramStmt> *,
const parser::Statement<parser::ModuleStmt> *,
- const parser::Statement<parser::SubmoduleStmt> *>;
+ const parser::Statement<parser::SubmoduleStmt> *,
+ const parser::Statement<parser::BlockDataStmt> *>;
ProgramTree(const parser::Name &name, const parser::SpecificationPart &spec,
const parser::ExecutionPart *exec = nullptr)
bool BeginSubprogram(
const parser::Name &, Symbol::Flag, bool hasModulePrefix = false);
bool BeginMpSubprogram(const parser::Name &);
+ Symbol &PushBlockDataScope(const parser::Name &);
void EndSubprogram();
protected:
// The name of a module or submodule cannot be "used" in its scope,
// as we read 19.3.1(2), so we allow the name to be used as a local
// identifier in the module or submodule too. Same with programs
- // (14.1(3)).
+ // (14.1(3)) and BLOCK DATA.
if (!currScope_->IsDerivedType() && kind != Scope::Kind::Module &&
- kind != Scope::Kind::MainProgram) {
+ kind != Scope::Kind::MainProgram && kind != Scope::Kind::BlockData) {
if (auto *symbol{scope.symbol()}) {
// Create a dummy symbol so we can't create another one with the same
// name. It might already be there if we previously pushed the scope.
return true;
}
-// A subprogram declared with SUBROUTINE or function
+// A subprogram declared with SUBROUTINE or FUNCTION
bool SubprogramVisitor::BeginSubprogram(
const parser::Name &name, Symbol::Flag subpFlag, bool hasModulePrefix) {
if (hasModulePrefix && !inInterfaceBlock()) {
return *symbol;
}
+Symbol &SubprogramVisitor::PushBlockDataScope(const parser::Name &name) {
+ if (auto *prev{FindSymbol(name)}) {
+ if (prev->attrs().test(Attr::EXTERNAL) && prev->has<ProcEntityDetails>()) {
+ if (prev->test(Symbol::Flag::Subroutine) ||
+ prev->test(Symbol::Flag::Function)) {
+ Say2(name, "BLOCK DATA '%s' has been called"_err_en_US, *prev,
+ "Previous call of '%s'"_en_US);
+ }
+ EraseSymbol(name);
+ }
+ }
+ Symbol &symbol{MakeSymbol(name, SubprogramDetails{})};
+ PushScope(Scope::Kind::BlockData, &symbol);
+ return symbol;
+}
+
// If name is a generic, return specific subprogram with the same name.
Symbol *SubprogramVisitor::GetSpecificFromGeneric(const parser::Name &name) {
if (auto *symbol{FindSymbol(name)}) {
bool ConstructVisitor::Pre(const parser::DataStmtObject &x) {
std::visit(
common::visitors{
- [&](const Indirection<parser::Variable> &y) { Walk(y.value()); },
+ [&](const Indirection<parser::Variable> &y) {
+ Walk(y.value());
+ if (const auto *expr{y.value().typedExpr.get()}) {
+ if (Symbol *
+ symbol{
+ const_cast<Symbol *>(evaluate::GetFirstSymbol(*expr))}) {
+ symbol->set(Symbol::Flag::InDataStmt);
+ }
+ }
+ },
[&](const parser::DataImpliedDo &y) {
PushScope(Scope::Kind::ImpliedDos, nullptr);
Walk(y);
return false;
}
break;
+ case Scope::Kind::BlockData:
+ Say("IMPORT is not allowed in a BLOCK DATA subprogram"_err_en_US);
+ return false;
default:;
}
if (auto error{scope.SetImportKind(x.kind)}) {
case ProgramTree::Kind::Module: BeginModule(node.name(), false); return true;
case ProgramTree::Kind::Submodule:
return BeginSubmodule(node.name(), node.GetParentId());
+ case ProgramTree::Kind::BlockData:
+ PushBlockDataScope(node.name());
+ return true;
}
}
using mapType = std::map<SourceName, common::Reference<Symbol>>;
public:
- ENUM_CLASS(Kind, Global, Module, MainProgram, Subprogram, DerivedType, Block,
- Forall, ImpliedDos)
+ ENUM_CLASS(Kind, Global, Module, MainProgram, Subprogram, BlockData,
+ DerivedType, Block, Forall, ImpliedDos)
using ImportKind = common::ImportKind;
// Create the Global scope -- the root of the scope tree
LocalityLocal, // named in LOCAL locality-spec
LocalityLocalInit, // named in LOCAL_INIT locality-spec
LocalityShared, // named in SHARED locality-spec
+ InDataStmt, // appears in a DATA statement
// OpenMP data-sharing attribute
OmpShared, OmpPrivate, OmpLinear, OmpFirstPrivate, OmpLastPrivate,
switch (scope->kind()) {
case Scope::Kind::Module:
case Scope::Kind::MainProgram:
- case Scope::Kind::Subprogram: return scope;
+ case Scope::Kind::Subprogram:
+ case Scope::Kind::BlockData: return scope;
case Scope::Kind::Global: return nullptr;
case Scope::Kind::DerivedType:
case Scope::Kind::Block:
}
}
+bool IsInitialized(const Symbol &symbol) {
+ if (symbol.test(Symbol::Flag::InDataStmt)) {
+ return true;
+ } else if (IsNamedConstant(symbol)) {
+ return false;
+ } else if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+ if (IsAllocatable(symbol) || object->init()) {
+ return true;
+ }
+ if (!IsPointer(symbol) && object->type()) {
+ if (const auto *derived{object->type()->AsDerived()}) {
+ if (derived->HasDefaultInitialization()) {
+ return true;
+ }
+ }
+ }
+ } else if (const auto *proc{symbol.detailsIf<ProcEntityDetails>()}) {
+ return proc->init().has_value();
+ }
+ return false;
+}
+
bool IsFinalizable(const Symbol &symbol) {
if (const DeclTypeSpec * type{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
// Has an explicit or implied SAVE attribute
bool IsSaved(const Symbol &);
bool CanBeTypeBoundProc(const Symbol *);
+bool IsInitialized(const Symbol &);
// Return an ultimate component of type that matches predicate, or nullptr.
const Symbol *FindUltimateComponent(const DerivedTypeSpec &type,
return typeSymbol_.get<DerivedTypeDetails>().isForwardReferenced();
}
+bool DerivedTypeSpec::HasDefaultInitialization() const {
+ for (const Scope *scope{scope_}; scope;
+ scope = scope->GetDerivedTypeParent()) {
+ for (const auto &pair : *scope) {
+ const Symbol &symbol{*pair.second};
+ if (IsAllocatable(symbol) || IsInitialized(symbol)) {
+ return true;
+ }
+ }
+ }
+ return false;
+}
+
ParamValue *DerivedTypeSpec::FindParameter(SourceName target) {
return const_cast<ParamValue *>(
const_cast<const DerivedTypeSpec *>(this)->FindParameter(target));
bool MightBeParameterized() const;
bool IsForwardReferenced() const;
+ bool HasDefaultInitialization() const;
// The "raw" type parameter list is a simple transcription from the
// parameter list in the parse tree, built by calling AddRawParamValue().
critical01.f90
critical02.f90
critical03.f90
+ block-data01.f90
)
# These test files have expected symbols in the source
--- /dev/null
+block data foo
+ real :: pi = asin(-1.0) ! ok
+ !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
+ procedure(sin), pointer :: p => cos
+ !ERROR: 'p' is already declared as a procedure
+ common /block/ pi, p
+ real :: inBlankCommon
+ data inBlankCommon / 1.0 /
+ common inBlankCommon
+end block data