[flang] More work on COMMON blocks

Common block names can't clash with other names, so add `commonBlocks_`
to `Scope` to record the common blocks of a scoping unit. This requires
changes to how scopes are dumped and written to `.mod` files.

Support common blocks in BIND statements. Add optional bind-name to
`CommonBlockDetails`.

Add `CheckNotInBlock()` for checking statements that are not allowed in
block constructs.

In `rewrite-parse-tree.cc`, no longer skip check for resolved names in
common statements. But do skip the checks in compiler directives.

Original-commit: flang-compiler/f18@805a1ffd9b7f33ce95d334ef5fe3e864b9f3d69e
Reviewed-on: https://github.com/flang-compiler/f18/pull/298
Tree-same-pre-rewrite: false

diff --git a/flang/lib/semantics/mod-file.cc b/flang/lib/semantics/mod-file.cc
index cfd49d3..d70b3ea 100644 (file)
--- a/flang/lib/semantics/mod-file.cc
+++ b/flang/lib/semantics/mod-file.cc
@@ -181,6 +181,10 @@ void ModFileWriter::PutSymbol(
               sep = ',';
             }
             decls_ << '\n';
+            if (symbol.attrs().test(Attr::BIND_C)) {
+              PutAttrs(decls_, symbol.attrs(), x.bindName(), ""s);
+              PutLower(decls_ << "::/", symbol) << "/\n";
+            }
           },
           [&](const FinalProcDetails &) {
             PutLower(typeBindings << "final::", symbol) << '\n';
@@ -310,6 +314,12 @@ std::vector<const Symbol *> CollectSymbols(const Scope &scope) {
       }
     }
   }
+  for (const auto &pair : scope.commonBlocks()) {
+    auto *symbol{pair.second};
+    if (symbols.insert(symbol).second) {
+      sorted.push_back(symbol);
+    }
+  }
   std::sort(sorted.begin(), sorted.end(), [](const Symbol *x, const Symbol *y) {
     bool xIsNml{x->has<NamelistDetails>()};
     bool yIsNml{y->has<NamelistDetails>()};

diff --git a/flang/lib/semantics/resolve-names.cc b/flang/lib/semantics/resolve-names.cc
index 9b49838..3adadbb 100644 (file)
--- a/flang/lib/semantics/resolve-names.cc
+++ b/flang/lib/semantics/resolve-names.cc
@@ -98,10 +98,9 @@ public:
   const SourceName *currStmtSource() { return currStmtSource_; }
   void set_currStmtSource(const SourceName *);
 
-  // Emit a message
-  Message &Say(Message &&);
   // Emit a message associated with the current statement source.
   Message &Say(MessageFixedText &&);
+  Message &Say(MessageFormattedText &&);
   // Emit a message about a SourceName
   Message &Say(const SourceName &, MessageFixedText &&);
   // Emit a formatted message associated with a source location.
@@ -620,10 +619,10 @@ public:
   using ArraySpecVisitor::Post;
   using ArraySpecVisitor::Pre;
 
+  bool Pre(const parser::ImplicitStmt &);
   void Post(const parser::EntityDecl &);
   void Post(const parser::ObjectDecl &);
   void Post(const parser::PointerDecl &);
-
   bool Pre(const parser::BindStmt &) { return BeginAttrs(); }
   void Post(const parser::BindStmt &) { EndAttrs(); }
   bool Pre(const parser::BindEntity &);
@@ -744,6 +743,7 @@ private:
   // the interface name, if any.
   const parser::Name *interfaceName_{nullptr};
 
+  bool CheckNotInBlock(const char *);
   bool HandleAttributeStmt(Attr, const std::list<parser::Name> &);
   Symbol &HandleAttributeStmt(Attr, const parser::Name &);
   Symbol &DeclareUnknownEntity(const parser::Name &, Attrs);
@@ -755,6 +755,7 @@ private:
   Symbol *MakeTypeSymbol(const parser::Name &, Details &&);
   bool OkToAddComponent(const parser::Name &, const Symbol * = nullptr);
   ParamValue GetParamValue(const parser::TypeParamValue &);
+  Symbol &MakeCommonBlockSymbol(const parser::Name &);
   void CheckCommonBlockDerivedType(const SourceName &, const Symbol &);
 
   // Declare an object or procedure entity.
@@ -931,7 +932,6 @@ public:
   bool Pre(const parser::MainProgram &);
   void Post(const parser::EndProgramStmt &);
   void Post(const parser::Program &);
-  bool Pre(const parser::ImplicitStmt &);
   void Post(const parser::PointerObject &);
   void Post(const parser::AllocateObject &);
   void Post(const parser::PointerAssignmentStmt &);
@@ -1115,6 +1115,7 @@ bool AttrsVisitor::SetBindNameOn(Symbol &symbol) {
           [&](ObjectEntityDetails &x) { x.set_bindName(std::move(bindName_)); },
           [&](ProcEntityDetails &x) { x.set_bindName(std::move(bindName_)); },
           [&](SubprogramDetails &x) { x.set_bindName(std::move(bindName_)); },
+          [&](CommonBlockDetails &x) { x.set_bindName(std::move(bindName_)); },
           [](auto &) { common::die("unexpected bind name"); },
       },
       symbol.details());
@@ -1250,6 +1251,10 @@ Message &MessageHandler::Say(MessageFixedText &&msg) {
   CHECK(currStmtSource_);
   return messages_->Say(*currStmtSource_, std::move(msg));
 }
+Message &MessageHandler::Say(MessageFormattedText &&msg) {
+  CHECK(currStmtSource_);
+  return messages_->Say(*currStmtSource_, std::move(msg));
+}
 Message &MessageHandler::Say(const SourceName &name, MessageFixedText &&msg) {
   return Say(name, std::move(msg), name);
 }
@@ -2443,6 +2448,10 @@ void DeclarationVisitor::Post(const parser::DimensionStmt::Declaration &x) {
   DeclareObjectEntity(name, Attrs{});
 }
 
+bool DeclarationVisitor::Pre(const parser::ImplicitStmt &x) {
+  return CheckNotInBlock("IMPLICIT") && ImplicitRulesVisitor::Pre(x);
+}
+
 void DeclarationVisitor::Post(const parser::EntityDecl &x) {
   // TODO: may be under StructureStmt
   const auto &name{std::get<parser::ObjectName>(x.t)};
@@ -2466,13 +2475,16 @@ void DeclarationVisitor::Post(const parser::PointerDecl &x) {
 }
 
 bool DeclarationVisitor::Pre(const parser::BindEntity &x) {
+  auto kind{std::get<parser::BindEntity::Kind>(x.t)};
   auto &name{std::get<parser::Name>(x.t)};
-  if (std::get<parser::BindEntity::Kind>(x.t) ==
-      parser::BindEntity::Kind::Object) {
-    HandleAttributeStmt(Attr::BIND_C, name);
+  Symbol *symbol;
+  if (kind == parser::BindEntity::Kind::Object) {
+    symbol = &HandleAttributeStmt(Attr::BIND_C, name);
   } else {
-    // TODO: name is common block
+    symbol = &MakeCommonBlockSymbol(name);
+    symbol->attrs().set(Attr::BIND_C);
   }
+  SetBindNameOn(*symbol);
   return false;
 }
 bool DeclarationVisitor::Pre(const parser::NamedConstantDef &x) {
@@ -2518,19 +2530,21 @@ bool DeclarationVisitor::Pre(const parser::ExternalStmt &x) {
 bool DeclarationVisitor::Pre(const parser::IntentStmt &x) {
   auto &intentSpec{std::get<parser::IntentSpec>(x.t)};
   auto &names{std::get<std::list<parser::Name>>(x.t)};
-  return HandleAttributeStmt(IntentSpecToAttr(intentSpec), names);
+  return CheckNotInBlock("INTENT") &&
+      HandleAttributeStmt(IntentSpecToAttr(intentSpec), names);
 }
 bool DeclarationVisitor::Pre(const parser::IntrinsicStmt &x) {
   return HandleAttributeStmt(Attr::INTRINSIC, x.v);
 }
 bool DeclarationVisitor::Pre(const parser::OptionalStmt &x) {
-  return HandleAttributeStmt(Attr::OPTIONAL, x.v);
+  return CheckNotInBlock("OPTIONAL") &&
+      HandleAttributeStmt(Attr::OPTIONAL, x.v);
 }
 bool DeclarationVisitor::Pre(const parser::ProtectedStmt &x) {
   return HandleAttributeStmt(Attr::PROTECTED, x.v);
 }
 bool DeclarationVisitor::Pre(const parser::ValueStmt &x) {
-  return HandleAttributeStmt(Attr::VALUE, x.v);
+  return CheckNotInBlock("VALUE") && HandleAttributeStmt(Attr::VALUE, x.v);
 }
 bool DeclarationVisitor::Pre(const parser::VolatileStmt &x) {
   return HandleAttributeStmt(Attr::VOLATILE, x.v);
@@ -2559,12 +2573,19 @@ Symbol &DeclarationVisitor::HandleAttributeStmt(
     symbol = &MakeSymbol(name, EntityDetails{});
   }
   symbol->attrs().set(attr);
-  if (SetBindNameOn(*symbol)) {
-    CHECK(attr == Attr::BIND_C);
-  }
   return *symbol;
 }
 
+bool DeclarationVisitor::CheckNotInBlock(const char *stmt) {
+  if (currScope().kind() == Scope::Kind::Block) {
+    Say(MessageFormattedText{
+        "%s statement is not allowed in a BLOCK construct"_err_en_US, stmt});
+    return false;
+  } else {
+    return true;
+  }
+}
+
 void DeclarationVisitor::Post(const parser::ObjectDecl &x) {
   CHECK(objectDeclAttr_.has_value());
   const auto &name{std::get<parser::ObjectName>(x.t)};
@@ -3174,8 +3195,7 @@ bool DeclarationVisitor::Pre(const parser::StructureConstructor &x) {
 }
 
 bool DeclarationVisitor::Pre(const parser::NamelistStmt::Group &x) {
-  if (currScope().kind() == Scope::Kind::Block) {
-    Say("NAMELIST statement is not allowed in a BLOCK construct"_err_en_US);
+  if (!CheckNotInBlock("NAMELIST")) {
     return false;
   }
 
@@ -3217,21 +3237,13 @@ bool DeclarationVisitor::Pre(const parser::IoControlSpec &x) {
 }
 
 bool DeclarationVisitor::Pre(const parser::CommonStmt::Block &x) {
+  CheckNotInBlock("COMMON");
   const auto &optName{std::get<std::optional<parser::Name>>(x.t)};
   parser::Name blankCommon;
   blankCommon.source = SourceName{currStmtSource()->begin(), std::size_t{0}};
-  const parser::Name &name{optName ? *optName : blankCommon};
-  auto *symbol{FindInScope(currScope(), name)};
-  if (symbol && !symbol->has<CommonBlockDetails>()) {
-    SayAlreadyDeclared(name, *symbol);
-    EraseSymbol(name);
-    symbol = nullptr;
-  }
-  if (!symbol) {
-    symbol = &MakeSymbol(name, CommonBlockDetails{});
-  }
   CHECK(!commonBlockInfo_.curr);
-  commonBlockInfo_.curr = symbol;
+  commonBlockInfo_.curr =
+      &MakeCommonBlockSymbol(optName ? *optName : blankCommon);
   return true;
 }
 
@@ -3269,9 +3281,22 @@ void DeclarationVisitor::Post(const parser::CommonBlockObject &x) {
 
 // Check types of common block objects, now that they are known.
 void DeclarationVisitor::CheckCommonBlocks() {
+  // check for empty common blocks
+  for (const auto pair : currScope().commonBlocks()) {
+    const auto &symbol{*pair.second};
+    if (symbol.get<CommonBlockDetails>().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 : commonBlockInfo_.names) {
     const auto *symbol{currScope().FindSymbol(name)};
-    CHECK(symbol);
+    if (symbol == nullptr) {
+      continue;
+    }
     const auto &attrs{symbol->attrs()};
     if (attrs.test(Attr::ALLOCATABLE)) {
       Say(name,
@@ -3302,6 +3327,10 @@ void DeclarationVisitor::CheckCommonBlocks() {
   commonBlockInfo_ = {};
 }
 
+Symbol &DeclarationVisitor::MakeCommonBlockSymbol(const parser::Name &name) {
+  return Resolve(name, currScope().MakeCommonBlock(name.source));
+}
+
 // Check if this derived type can be in a COMMON block.
 void DeclarationVisitor::CheckCommonBlockDerivedType(
     const SourceName &name, const Symbol &typeSymbol) {
@@ -4271,14 +4300,6 @@ bool ResolveNamesVisitor::Pre(const parser::MainProgram &x) {
 
 void ResolveNamesVisitor::Post(const parser::EndProgramStmt &) { PopScope(); }
 
-bool ResolveNamesVisitor::Pre(const parser::ImplicitStmt &x) {
-  if (currScope().kind() == Scope::Kind::Block) {
-    Say("IMPLICIT statement is not allowed in BLOCK construct"_err_en_US);
-    return false;
-  }
-  return ImplicitRulesVisitor::Pre(x);
-}
-
 void ResolveNamesVisitor::Post(const parser::PointerObject &x) {
   std::visit(
       common::visitors{

diff --git a/flang/lib/semantics/rewrite-parse-tree.cc b/flang/lib/semantics/rewrite-parse-tree.cc
index 5890e21..841ca5e 100644 (file)
--- a/flang/lib/semantics/rewrite-parse-tree.cc
+++ b/flang/lib/semantics/rewrite-parse-tree.cc
@@ -41,10 +41,10 @@ public:
   void Post(parser::Expr &x) { ConvertFunctionRef(x); }
 
   // Name resolution yet implemented:
-  bool Pre(parser::CommonStmt &) { return false; }
   bool Pre(parser::EquivalenceStmt &) { return false; }
   bool Pre(parser::Keyword &) { return false; }
   bool Pre(parser::EntryStmt &) { return false; }
+  bool Pre(parser::CompilerDirective &) { return false; }
 
   // Don't bother resolving names in end statements.
   bool Pre(parser::EndBlockDataStmt &) { return false; }

diff --git a/flang/lib/semantics/scope.cc b/flang/lib/semantics/scope.cc
index 4f39bef..fa80c4b 100644 (file)
--- a/flang/lib/semantics/scope.cc
+++ b/flang/lib/semantics/scope.cc
@@ -58,6 +58,21 @@ Symbol *Scope::FindSymbol(const SourceName &name) const {
     return nullptr;
   }
 }
+Symbol &Scope::MakeCommonBlock(const SourceName &name) {
+  const auto it{commonBlocks_.find(name)};
+  if (it != commonBlocks_.end()) {
+    return *it->second;
+  } else {
+    Symbol &symbol{MakeSymbol(name, Attrs{}, CommonBlockDetails{})};
+    commonBlocks_.emplace(name, &symbol);
+    return symbol;
+  }
+}
+Symbol *Scope::FindCommonBlock(const SourceName &name) {
+  const auto it{commonBlocks_.find(name)};
+  return it != commonBlocks_.end() ? it->second : nullptr;
+}
+
 Scope *Scope::FindSubmodule(const SourceName &name) const {
   auto it{submodules_.find(name)};
   if (it == submodules_.end()) {
@@ -204,6 +219,10 @@ std::ostream &operator<<(std::ostream &os, const Scope &scope) {
     const auto *symbol{pair.second};
     os << "  " << *symbol << '\n';
   }
+  for (const auto &pair : scope.commonBlocks_) {
+    const auto *symbol{pair.second};
+    os << "  " << *symbol << '\n';
+  }
   return os;
 }
 

diff --git a/flang/lib/semantics/scope.h b/flang/lib/semantics/scope.h
index ded89c3..c1fd911 100644 (file)
--- a/flang/lib/semantics/scope.h
+++ b/flang/lib/semantics/scope.h
@@ -119,6 +119,11 @@ public:
     return symbols_.emplace(name, &symbol);
   }
 
+  mapType &commonBlocks() { return commonBlocks_; }
+  const mapType &commonBlocks() const { return commonBlocks_; }
+  Symbol &MakeCommonBlock(const SourceName &);
+  Symbol *FindCommonBlock(const SourceName &);
+
   /// Make a Symbol but don't add it to the scope.
   template<typename D>
   Symbol &MakeSymbol(const SourceName &name, Attrs attrs, D &&details) {
@@ -193,6 +198,7 @@ private:
   Symbol *const symbol_;  // if not null, symbol_->scope() == this
   std::list<Scope> children_;
   mapType symbols_;
+  mapType commonBlocks_;
   std::map<SourceName, Scope *> submodules_;
   std::list<DeclTypeSpec> declTypeSpecs_;
   std::string chars_;

diff --git a/flang/lib/semantics/semantics.cc b/flang/lib/semantics/semantics.cc
index cd293c9..516b370 100644 (file)
--- a/flang/lib/semantics/semantics.cc
+++ b/flang/lib/semantics/semantics.cc
@@ -117,6 +117,11 @@ void DoDumpSymbols(std::ostream &os, const Scope &scope, int indent) {
       }
     }
   }
+  for (const auto &pair : scope.commonBlocks()) {
+    const auto &symbol{*pair.second};
+    PutIndent(os, indent);
+    os << symbol << '\n';
+  }
   for (const auto &child : scope.children()) {
     DoDumpSymbols(os, child, indent);
   }

diff --git a/flang/lib/semantics/symbol.cc b/flang/lib/semantics/symbol.cc
index 9e8b084..6e978cf 100644 (file)
--- a/flang/lib/semantics/symbol.cc
+++ b/flang/lib/semantics/symbol.cc
@@ -387,13 +387,13 @@ std::ostream &operator<<(std::ostream &os, const Details &details) {
             }
           },
           [&](const NamelistDetails &x) {
-            os << ": ";
+            os << ':';
             for (const auto *object : x.objects()) {
               os << ' ' << object->name();
             }
           },
           [&](const CommonBlockDetails &x) {
-            os << ": ";
+            os << ':';
             for (const auto *object : x.objects()) {
               os << ' ' << object->name();
             }

diff --git a/flang/lib/semantics/symbol.h b/flang/lib/semantics/symbol.h
index 9dc89fd..18c0479 100644 (file)
--- a/flang/lib/semantics/symbol.h
+++ b/flang/lib/semantics/symbol.h
@@ -278,9 +278,12 @@ class CommonBlockDetails {
 public:
   SymbolList objects() const { return objects_; }
   void add_object(Symbol &object) { objects_.push_back(&object); }
+  MaybeExpr bindName() const { return bindName_; }
+  void set_bindName(MaybeExpr &&expr) { bindName_ = std::move(expr); }
 
 private:
   SymbolList objects_;
+  MaybeExpr bindName_;
 };
 
 class FinalProcDetails {};

diff --git a/flang/test/semantics/implicit08.f90 b/flang/test/semantics/implicit08.f90
index ea8de3e..0d98c4f 100644 (file)
--- a/flang/test/semantics/implicit08.f90
+++ b/flang/test/semantics/implicit08.f90
@@ -1,4 +1,4 @@
-! Copyright (c) 2018, NVIDIA CORPORATION.  All rights reserved.
+! Copyright (c) 2018-2019, NVIDIA CORPORATION.  All rights reserved.
 !
 ! Licensed under the Apache License, Version 2.0 (the "License");
 ! you may not use this file except in compliance with the License.
@@ -14,7 +14,7 @@
 
 subroutine s1
   block
-    !ERROR: IMPLICIT statement is not allowed in BLOCK construct
+    !ERROR: IMPLICIT statement is not allowed in a BLOCK construct
     implicit logical(a)
   end block
 end subroutine

diff --git a/flang/test/semantics/modfile21.f90 b/flang/test/semantics/modfile21.f90
index 13be400..04a5ce9 100644 (file)
--- a/flang/test/semantics/modfile21.f90
+++ b/flang/test/semantics/modfile21.f90
@@ -14,6 +14,7 @@
 
 module m
   logical b
+  bind(C) :: /cb2/
   common //t
   common /cb/ x(2:10) /cb2/a,b,c
   common /cb/ y,z
@@ -21,16 +22,20 @@ module m
   common u,v
   complex w
   dimension b(4,4)
+  bind(C, name="CB") /cb/
+  common /b/ cb
 end
 
 !Expect: m.mod
 !module m
 !  logical(4)::b(1_8:4_8,1_8:4_8)
+!  common/cb2/a,b,c
+!  bind(c)::/cb2/
 !  common//t,w,u,v
 !  real(4)::t
 !  common/cb/x,y,z
+!  bind(c, name=1_"CB")::/cb/
 !  real(4)::x(2_8:10_8)
-!  common/cb2/a,b,c
 !  real(4)::a
 !  real(4)::c
 !  real(4)::y
@@ -38,4 +43,6 @@ end
 !  complex(4)::w
 !  real(4)::u
 !  real(4)::v
+!  common/b/cb
+!  real(4)::cb
 !end

diff --git a/flang/test/semantics/resolve42.f90 b/flang/test/semantics/resolve42.f90
index 854f093..22461c9 100644 (file)
--- a/flang/test/semantics/resolve42.f90
+++ b/flang/test/semantics/resolve42.f90
@@ -32,14 +32,6 @@ subroutine s3
   procedure(real) :: y
 end
 
-subroutine s4
-  integer x
-  !ERROR: 'x' is already declared in this scoping unit
-  common /x/ y
-  !ERROR: 's4' is already declared in this scoping unit
-  common /s4/ z
-end
-
 subroutine s5
   integer x(2)
   !ERROR: The dimensions of 'x' have already been declared
@@ -56,9 +48,11 @@ subroutine s6(x)
 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
-  common z
+  common w,z
   integer, bind(c) :: z
+  integer, bind(c,name="w") :: w
 end
 
 module m8
@@ -117,3 +111,15 @@ module m12
   !ERROR: Derived type variable 'x2' may not appear in a COMMON block due to component with default initialization
   common x2
 end
+
+subroutine s13
+  block
+    !ERROR: COMMON statement is not allowed in a BLOCK construct
+    common x
+  end block
+end
+
+subroutine s14
+  !ERROR: 'c' appears as a COMMON block in a BIND statement but not in a COMMON statement
+  bind(c) :: /c/
+end