[flang] BLOCK DATA

add test

Original-commit: flang-compiler/f18@91c084b698
Reviewed-on: https://github.com/flang-compiler/f18/pull/926
Tree-same-pre-rewrite: false

flang/lib/semantics/check-declarations.cc

@@ -17,6 +17,7 @@
 #include "../evaluate/check-expression.h"
 #include "../evaluate/fold.h"
 #include "../evaluate/tools.h"
+#include <algorithm>
 
 namespace Fortran::semantics {
 
@@ -71,6 +72,9 @@ private:
   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);
@@ -350,6 +354,18 @@ void CheckHelper::CheckObjectEntity(
       }
     }
   }
+  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:
@@ -1005,12 +1021,39 @@ void CheckHelper::Check(const Scope &scope) {
   } 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) {

flang/lib/semantics/check-return.cc

@@ -14,16 +14,13 @@
 
 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) {
@@ -33,18 +30,17 @@ 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
+}

flang/lib/semantics/program-tree.cc

@@ -31,6 +31,12 @@ static ProgramTree BuildSubprogramTree(const parser::Name &name, const T &x) {
   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)};
@@ -97,8 +103,13 @@ ProgramTree ProgramTree::Build(const parser::Submodule &x) {
   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 {
@@ -161,6 +172,9 @@ ProgramTree::Kind ProgramTree::GetKind() const {
           [](const parser::Statement<parser::SubmoduleStmt> *) {
             return Kind::Submodule;
           },
+          [](const parser::Statement<parser::BlockDataStmt> *) {
+            return Kind::BlockData;
+          },
       },
       stmt_);
 }

flang/lib/semantics/program-tree.h

@@ -39,14 +39,15 @@ public:
   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)

flang/lib/semantics/resolve-names.cc

@@ -661,6 +661,7 @@ public:
   bool BeginSubprogram(
       const parser::Name &, Symbol::Flag, bool hasModulePrefix = false);
   bool BeginMpSubprogram(const parser::Name &);
+  Symbol &PushBlockDataScope(const parser::Name &);
   void EndSubprogram();
 
 protected:
@@ -1916,9 +1917,9 @@ void ScopeHandler::PushScope(Scope &scope) {
   // 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.
@@ -2736,7 +2737,7 @@ bool SubprogramVisitor::BeginMpSubprogram(const parser::Name &name) {
   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()) {
@@ -2789,6 +2790,22 @@ Symbol &SubprogramVisitor::PushSubprogramScope(
   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)}) {
@@ -4595,7 +4612,16 @@ bool ConstructVisitor::Pre(const parser::DataImpliedDo &x) {
 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);
@@ -4953,6 +4979,9 @@ bool ResolveNamesVisitor::Pre(const parser::ImportStmt &x) {
       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)}) {
@@ -5793,6 +5822,9 @@ bool ResolveNamesVisitor::BeginScope(const ProgramTree &node) {
   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;
   }
 }
 

flang/lib/semantics/scope.h

@@ -50,8 +50,8 @@ class Scope {
   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

flang/lib/semantics/symbol.h

@@ -458,6 +458,7 @@ public:
       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,

flang/lib/semantics/tools.cc

@@ -49,7 +49,8 @@ const Scope *FindProgramUnitContaining(const Scope &start) {
     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:
@@ -617,6 +618,28 @@ bool CanBeTypeBoundProc(const Symbol *symbol) {
   }
 }
 
+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()}) {

flang/lib/semantics/tools.h

@@ -102,6 +102,7 @@ bool IsOrContainsEventOrLockComponent(const Symbol &);
 // 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,

flang/lib/semantics/type.cc

@@ -171,6 +171,19 @@ bool DerivedTypeSpec::IsForwardReferenced() const {
   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));

flang/lib/semantics/type.h

@@ -247,6 +247,7 @@ public:
 
   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().

flang/test/semantics/CMakeLists.txt

@@ -199,6 +199,7 @@ set(ERROR_TESTS
   critical01.f90
   critical02.f90
   critical03.f90
+  block-data01.f90
 )
 
 # These test files have expected symbols in the source

flang/test/semantics/block-data01.f90

@@ -0,0 +1,13 @@
+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