[flang] Handle common block with different sizes in same file

Semantics is not preventing a named common block to appear with
different size in a same file (named common block should always have
the same storage size (see Fortran 2018 8.10.2.5), but it is a common
extension to accept different sizes).

Lowering was not coping with this well, since it just use the first
common block appearance, starting with BLOCK DATAs to define common
blocks (this also was an issue with the blank common block, which can
legally appear with different size in different scoping units).

Semantics is also not preventing named common from being initialized
outside of a BLOCK DATA, and lowering was dealing badly with this,
since it only gave an initial value to common blocks Globals if the
first common block appearance, starting with BLOCK DATAs had an initial
value.

Semantics is also allowing blank common to be initialized, while
lowering was assuming this would never happen, and was never creating
an initial value for it.

Lastly, semantics was not complaining if a COMMON block was initialized
in several scoping unit in a same file, while lowering can only generate
one of these initial value.

To fix this, add a structure to keep track of COMMON block properties
(biggest size, and initial value if any) at the Program level. Once the
size of a common block appearance is know, the common block appearance
is checked against this information. It allows semantics to emit an error
in case of multiple initialization in different scopes of a same common
block, and to warn in case named common blocks appears with different
sizes. Lastly, this allows lowering to use the Program level info about
common blocks to emit the right GlobalOp for a Common Block, regardless
of the COMMON Block appearances order: It emits a GlobalOp with the
biggest size, whose lowest bytes are initialized with the initial value
if any is given in a scope where the common block appears.

Lowering is updated to go emit the common blocks before anything else so
that the related GlobalOps are available when lowering the scopes where
common block appear. It is also updated to not assume that blank common
are never initialized.

Differential Revision: https://reviews.llvm.org/D124622

flang/docs/Extensions.md

@@ -206,6 +206,7 @@ end
 * External unit 0 is predefined and connected to the standard error output,
   and defined as `ERROR_UNIT` in the intrinsic `ISO_FORTRAN_ENV` module.
 * Objects in blank COMMON may be initialized.
+* Initialization of COMMON blocks outside of BLOCK DATA subprograms.
 * Multiple specifications of the SAVE attribute on the same object
   are allowed, with a warning.
 * Specific intrinsic functions BABS, IIABS, JIABS, KIABS, ZABS, and CDABS.

flang/include/flang/Lower/ConvertVariable.h

@@ -54,6 +54,14 @@ void instantiateVariable(AbstractConverter &, const pft::Variable &var,
 /// called.
 void defineModuleVariable(AbstractConverter &, const pft::Variable &var);
 
+/// Create fir::GlobalOp for all common blocks, including their initial values
+/// if they have one. This should be called before lowering any scopes so that
+/// common block globals are available when a common appear in a scope.
+void defineCommonBlocks(
+    AbstractConverter &,
+    const std::vector<std::pair<semantics::SymbolRef, std::size_t>>
+        &commonBlocks);
+
 /// Lower a symbol attributes given an optional storage \p and add it to the
 /// provided symbol map. If \preAlloc is not provided, a temporary storage will
 /// be allocated. This is a low level function that should only be used if

flang/include/flang/Lower/PFTBuilder.h

@@ -24,6 +24,7 @@
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/attr.h"
 #include "flang/Semantics/scope.h"
+#include "flang/Semantics/semantics.h"
 #include "flang/Semantics/symbol.h"
 #include "llvm/Support/ErrorHandling.h"
 #include "llvm/Support/raw_ostream.h"
@@ -737,18 +738,23 @@ struct Program {
   using Units = std::variant<FunctionLikeUnit, ModuleLikeUnit, BlockDataUnit,
                              CompilerDirectiveUnit>;
 
-  Program() = default;
+  Program(semantics::CommonBlockList &&commonBlocks)
+      : commonBlocks{std::move(commonBlocks)} {}
   Program(Program &&) = default;
   Program(const Program &) = delete;
 
   const std::list<Units> &getUnits() const { return units; }
   std::list<Units> &getUnits() { return units; }
+  const semantics::CommonBlockList &getCommonBlocks() const {
+    return commonBlocks;
+  }
 
   /// LLVM dump method on a Program.
   LLVM_DUMP_METHOD void dump() const;
 
 private:
   std::list<Units> units;
+  semantics::CommonBlockList commonBlocks;
 };
 
 /// Return the list of variables that appears in the specification expressions

flang/include/flang/Semantics/semantics.h

@@ -49,6 +49,8 @@ struct WhereConstruct;
 namespace Fortran::semantics {
 
 class Symbol;
+class CommonBlockMap;
+using CommonBlockList = std::vector<std::pair<SymbolRef, std::size_t>>;
 
 using ConstructNode = std::variant<const parser::AssociateConstruct *,
     const parser::BlockConstruct *, const parser::CaseConstruct *,
@@ -199,6 +201,30 @@ public:
   // during semantics.
   parser::Program &SaveParseTree(parser::Program &&);
 
+  // Ensures a common block definition does not conflict with previous
+  // appearances in the program and consolidate information about
+  // common blocks at the program level for later checks and lowering.
+  // This can obviously not check any conflicts between different compilation
+  // units (in case such conflicts exist, the behavior will depend on the
+  // linker).
+  void MapCommonBlockAndCheckConflicts(const Symbol &);
+
+  // Get the list of common blocks appearing in the program. If a common block
+  // appears in several subprograms, only one of its appearance is returned in
+  // the list alongside the biggest byte size of all its appearances.
+  // If a common block is initialized in any of its appearances, the list will
+  // contain the appearance with the initialization, otherwise the appearance
+  // with the biggest size is returned. The extra byte size information allows
+  // handling the case where the common block initialization is not the
+  // appearance with the biggest size: the common block will have the biggest
+  // size with the first bytes initialized with the initial value. This is not
+  // standard, if the initialization and biggest size appearances are in
+  // different compilation units, the behavior will depend on the linker. The
+  // linker may have the behavior described before, but it may also keep the
+  // initialized common symbol without extending its size, or have some other
+  // behavior.
+  CommonBlockList GetCommonBlocks() const;
+
 private:
   void CheckIndexVarRedefine(
       const parser::CharBlock &, const Symbol &, parser::MessageFixedText &&);
@@ -231,6 +257,7 @@ private:
   std::set<std::string> tempNames_;
   const Scope *builtinsScope_{nullptr}; // module __Fortran_builtins
   std::list<parser::Program> modFileParseTrees_;
+  std::unique_ptr<CommonBlockMap> commonBlockMap_;
 };
 
 class Semantics {

flang/lib/Lower/Bridge.cpp

@@ -178,29 +178,35 @@ public:
   /// Convert the PFT to FIR.
   void run(Fortran::lower::pft::Program &pft) {
     // Preliminary translation pass.
+
+    // - Lower common blocks from the PFT common block list that contains a
+    // consolidated list of the common blocks (with the initialization if any in
+    // the Program, and with the common block biggest size in all its
+    // appearance). This is done before lowering any scope declarations because
+    // it is not know at the local scope level what MLIR type common blocks
+    // should have to suit all its usage in the compilation unit.
+    lowerCommonBlocks(pft.getCommonBlocks());
+
     //  - Declare all functions that have definitions so that definition
     //    signatures prevail over call site signatures.
     //  - Define module variables and OpenMP/OpenACC declarative construct so
     //    that they are available before lowering any function that may use
     //    them.
-    //  - Translate block data programs so that common block definitions with
-    //    data initializations take precedence over other definitions.
     for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
-      std::visit(
-          Fortran::common::visitors{
-              [&](Fortran::lower::pft::FunctionLikeUnit &f) {
-                declareFunction(f);
-              },
-              [&](Fortran::lower::pft::ModuleLikeUnit &m) {
-                lowerModuleDeclScope(m);
-                for (Fortran::lower::pft::FunctionLikeUnit &f :
-                     m.nestedFunctions)
-                  declareFunction(f);
-              },
-              [&](Fortran::lower::pft::BlockDataUnit &b) { lowerBlockData(b); },
-              [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
-          },
-          u);
+      std::visit(Fortran::common::visitors{
+                     [&](Fortran::lower::pft::FunctionLikeUnit &f) {
+                       declareFunction(f);
+                     },
+                     [&](Fortran::lower::pft::ModuleLikeUnit &m) {
+                       lowerModuleDeclScope(m);
+                       for (Fortran::lower::pft::FunctionLikeUnit &f :
+                            m.nestedFunctions)
+                         declareFunction(f);
+                     },
+                     [&](Fortran::lower::pft::BlockDataUnit &b) {},
+                     [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
+                 },
+                 u);
     }
 
     // Primary translation pass.
@@ -2562,6 +2568,13 @@ private:
     });
   }
 
+  /// Create fir::Global for all the common blocks that appear in the program.
+  void
+  lowerCommonBlocks(const Fortran::semantics::CommonBlockList &commonBlocks) {
+    createGlobalOutsideOfFunctionLowering(
+        [&]() { Fortran::lower::defineCommonBlocks(*this, commonBlocks); });
+  }
+
   /// Lower a procedure (nest).
   void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
     if (!funit.isMainProgram()) {

flang/lib/Lower/ConvertVariable.cpp

@@ -882,47 +882,82 @@ getCommonMembersWithInitAliases(const Fortran::semantics::Symbol &common) {
   return members;
 }
 
-/// Define a global for a common block if it does not already exist in the
-/// mlir module.
-/// There is no "declare" version since there is not a
-/// scope that owns common blocks more that the others. All scopes using
-/// a common block attempts to define it with common linkage.
+/// Return the fir::GlobalOp that was created of COMMON block \p common.
+/// It is an error if the fir::GlobalOp was not created before this is
+/// called (it cannot be created on the flight because it is not known here
+/// what mlir type the GlobalOp should have to satisfy all the
+/// appearances in the program).
 static fir::GlobalOp
-defineCommonBlock(Fortran::lower::AbstractConverter &converter,
-                  const Fortran::semantics::Symbol &common) {
+getCommonBlockGlobal(Fortran::lower::AbstractConverter &converter,
+                     const Fortran::semantics::Symbol &common) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  std::string commonName = Fortran::lower::mangle::mangleName(common);
+  fir::GlobalOp global = builder.getNamedGlobal(commonName);
+  // Common blocks are lowered before any subprograms to deal with common
+  // whose size may not be the same in every subprograms.
+  if (!global)
+    fir::emitFatalError(converter.genLocation(common.name()),
+                        "COMMON block was not lowered before its usage");
+  return global;
+}
+
+/// Create the fir::GlobalOp for COMMON block \p common. If \p common has an
+/// initial value, it is not created yet. Instead, the common block list
+/// members is returned to later create the initial value in
+/// finalizeCommonBlockDefinition.
+static std::optional<std::tuple<
+    fir::GlobalOp, Fortran::semantics::MutableSymbolVector, mlir::Location>>
+declareCommonBlock(Fortran::lower::AbstractConverter &converter,
+                   const Fortran::semantics::Symbol &common,
+                   std::size_t commonSize) {
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   std::string commonName = Fortran::lower::mangle::mangleName(common);
   fir::GlobalOp global = builder.getNamedGlobal(commonName);
   if (global)
-    return global;
+    return std::nullopt;
   Fortran::semantics::MutableSymbolVector cmnBlkMems =
       getCommonMembersWithInitAliases(common);
   mlir::Location loc = converter.genLocation(common.name());
-  mlir::IndexType idxTy = builder.getIndexType();
   mlir::StringAttr linkage = builder.createCommonLinkage();
-  if (!common.name().size() || !commonBlockHasInit(cmnBlkMems)) {
-    // A blank (anonymous) COMMON block must always be initialized to zero.
-    // A named COMMON block sans initializers is also initialized to zero.
+  if (!commonBlockHasInit(cmnBlkMems)) {
+    // A COMMON block sans initializers is initialized to zero.
     // mlir::Vector types must have a strictly positive size, so at least
     // temporarily, force a zero size COMMON block to have one byte.
-    const auto sz = static_cast<fir::SequenceType::Extent>(
-        common.size() > 0 ? common.size() : 1);
+    const auto sz =
+        static_cast<fir::SequenceType::Extent>(commonSize > 0 ? commonSize : 1);
     fir::SequenceType::Shape shape = {sz};
     mlir::IntegerType i8Ty = builder.getIntegerType(8);
     auto commonTy = fir::SequenceType::get(shape, i8Ty);
     auto vecTy = mlir::VectorType::get(sz, i8Ty);
     mlir::Attribute zero = builder.getIntegerAttr(i8Ty, 0);
     auto init = mlir::DenseElementsAttr::get(vecTy, llvm::makeArrayRef(zero));
-    return builder.createGlobal(loc, commonTy, commonName, linkage, init);
+    builder.createGlobal(loc, commonTy, commonName, linkage, init);
+    // No need to add any initial value later.
+    return std::nullopt;
   }
-
-  // Named common with initializer, sort members by offset before generating
-  // the type and initializer.
+  // COMMON block with initializer (note that initialized blank common are
+  // accepted as an extension by semantics). Sort members by offset before
+  // generating the type and initializer.
   std::sort(cmnBlkMems.begin(), cmnBlkMems.end(),
             [](auto &s1, auto &s2) { return s1->offset() < s2->offset(); });
   mlir::TupleType commonTy =
-      getTypeOfCommonWithInit(converter, cmnBlkMems, common.size());
+      getTypeOfCommonWithInit(converter, cmnBlkMems, commonSize);
+  // Create the global object, the initial value will be added later.
+  global = builder.createGlobal(loc, commonTy, commonName);
+  return std::make_tuple(global, std::move(cmnBlkMems), loc);
+}
+
+/// Add initial value to a COMMON block fir::GlobalOp \p global given the list
+/// \p cmnBlkMems of the common block member symbols that contains symbols with
+/// an initial value.
+static void finalizeCommonBlockDefinition(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    fir::GlobalOp global,
+    const Fortran::semantics::MutableSymbolVector &cmnBlkMems) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::TupleType commonTy = global.getType().cast<mlir::TupleType>();
   auto initFunc = [&](fir::FirOpBuilder &builder) {
+    mlir::IndexType idxTy = builder.getIndexType();
     mlir::Value cb = builder.create<fir::UndefOp>(loc, commonTy);
     unsigned tupIdx = 0;
     std::size_t offset = 0;
@@ -957,10 +992,25 @@ defineCommonBlock(Fortran::lower::AbstractConverter &converter,
     LLVM_DEBUG(llvm::dbgs() << "}\n");
     builder.create<fir::HasValueOp>(loc, cb);
   };
-  // create the global object
-  return builder.createGlobal(loc, commonTy, commonName,
-                              /*isConstant=*/false, initFunc);
+  createGlobalInitialization(builder, global, initFunc);
 }
+
+void Fortran::lower::defineCommonBlocks(
+    Fortran::lower::AbstractConverter &converter,
+    const Fortran::semantics::CommonBlockList &commonBlocks) {
+  // Common blocks may depend on another common block address (if they contain
+  // pointers with initial targets). To cover this case, create all common block
+  // fir::Global before creating the initial values (if any).
+  std::vector<std::tuple<fir::GlobalOp, Fortran::semantics::MutableSymbolVector,
+                         mlir::Location>>
+      delayedInitializations;
+  for (const auto [common, size] : commonBlocks)
+    if (auto delayedInit = declareCommonBlock(converter, common, size))
+      delayedInitializations.emplace_back(std::move(*delayedInit));
+  for (auto &[global, cmnBlkMems, loc] : delayedInitializations)
+    finalizeCommonBlockDefinition(loc, converter, global, cmnBlkMems);
+}
+
 /// The COMMON block is a global structure. `var` will be at some offset
 /// within the COMMON block. Adds the address of `var` (COMMON + offset) to
 /// the symbol map.
@@ -977,7 +1027,7 @@ static void instantiateCommon(Fortran::lower::AbstractConverter &converter,
     commonAddr = symBox.getAddr();
   if (!commonAddr) {
     // introduce a local AddrOf and add it to the map
-    fir::GlobalOp global = defineCommonBlock(converter, common);
+    fir::GlobalOp global = getCommonBlockGlobal(converter, common);
     commonAddr = builder.create<fir::AddrOfOp>(loc, global.resultType(),
                                                global.getSymbol());
 
@@ -1761,8 +1811,9 @@ void Fortran::lower::defineModuleVariable(
   const Fortran::semantics::Symbol &sym = var.getSymbol();
   if (const Fortran::semantics::Symbol *common =
           Fortran::semantics::FindCommonBlockContaining(var.getSymbol())) {
-    // Define common block containing the variable.
-    defineCommonBlock(converter, *common);
+    // Nothing to do, common block are generated before everything. Ensure
+    // this was done by calling getCommonBlockGlobal.
+    getCommonBlockGlobal(converter, *common);
   } else if (var.isAlias()) {
     // Do nothing. Mapping will be done on user side.
   } else {

flang/lib/Lower/PFTBuilder.cpp

@@ -76,8 +76,9 @@ struct UnwrapStmt<parser::UnlabeledStatement<A>> {
 class PFTBuilder {
 public:
   PFTBuilder(const semantics::SemanticsContext &semanticsContext)
-      : pgm{std::make_unique<lower::pft::Program>()}, semanticsContext{
-                                                          semanticsContext} {
+      : pgm{std::make_unique<lower::pft::Program>(
+            semanticsContext.GetCommonBlocks())},
+        semanticsContext{semanticsContext} {
     lower::pft::PftNode pftRoot{*pgm.get()};
     pftParentStack.push_back(pftRoot);
   }

flang/lib/Semantics/compute-offsets.cpp

@@ -200,6 +200,7 @@ void ComputeOffsetsHelper::DoCommonBlock(Symbol &commonBlock) {
   }
   commonBlock.set_size(std::max(minSize, offset_));
   details.set_alignment(std::max(minAlignment, alignment_));
+  context_.MapCommonBlockAndCheckConflicts(commonBlock);
 }
 
 void ComputeOffsetsHelper::DoEquivalenceBlockBase(

flang/lib/Semantics/semantics.cpp

@@ -178,6 +178,109 @@ static bool PerformStatementSemantics(
   return !context.AnyFatalError();
 }
 
+/// This class keeps track of the common block appearances with the biggest size
+/// and with an initial value (if any) in a program. This allows reporting
+/// conflicting initialization and warning about appearances of a same
+/// named common block with different sizes. The biggest common block size and
+/// initialization (if any) can later be provided so that lowering can generate
+/// the correct symbol size and initial values, even when named common blocks
+/// appears with different sizes and are initialized outside of block data.
+class CommonBlockMap {
+private:
+  struct CommonBlockInfo {
+    // Common block symbol for the appearance with the biggest size.
+    SymbolRef biggestSize;
+    // Common block symbol for the appearance with the initialized members (if
+    // any).
+    std::optional<SymbolRef> initialization;
+  };
+
+public:
+  void MapCommonBlockAndCheckConflicts(
+      SemanticsContext &context, const Symbol &common) {
+    const Symbol *isInitialized{CommonBlockIsInitialized(common)};
+    auto [it, firstAppearance] = commonBlocks_.insert({common.name(),
+        isInitialized ? CommonBlockInfo{common, common}
+                      : CommonBlockInfo{common, std::nullopt}});
+    if (!firstAppearance) {
+      CommonBlockInfo &info{it->second};
+      if (isInitialized) {
+        if (info.initialization.has_value() &&
+            &**info.initialization != &common) {
+          // Use the location of the initialization in the error message because
+          // common block symbols may have no location if they are blank
+          // commons.
+          const Symbol &previousInit{
+              DEREF(CommonBlockIsInitialized(**info.initialization))};
+          context
+              .Say(isInitialized->name(),
+                  "Multiple initialization of COMMON block /%s/"_err_en_US,
+                  common.name())
+              .Attach(previousInit.name(),
+                  "Previous initialization of COMMON block /%s/"_en_US,
+                  common.name());
+        } else {
+          info.initialization = common;
+        }
+      }
+      if (common.size() != info.biggestSize->size() && !common.name().empty()) {
+        context
+            .Say(common.name(),
+                "A named COMMON block should have the same size everywhere it appears (%zd bytes here)"_port_en_US,
+                common.size())
+            .Attach(info.biggestSize->name(),
+                "Previously defined with a size of %zd bytes"_en_US,
+                info.biggestSize->size());
+      }
+      if (common.size() > info.biggestSize->size()) {
+        info.biggestSize = common;
+      }
+    }
+  }
+
+  CommonBlockList GetCommonBlocks() const {
+    CommonBlockList result;
+    for (const auto &[_, blockInfo] : commonBlocks_) {
+      result.emplace_back(
+          std::make_pair(blockInfo.initialization ? *blockInfo.initialization
+                                                  : blockInfo.biggestSize,
+              blockInfo.biggestSize->size()));
+    }
+    return result;
+  }
+
+private:
+  /// Return the symbol of an initialized member if a COMMON block
+  /// is initalized. Otherwise, return nullptr.
+  static Symbol *CommonBlockIsInitialized(const Symbol &common) {
+    const auto &commonDetails =
+        common.get<Fortran::semantics::CommonBlockDetails>();
+
+    for (const auto &member : commonDetails.objects()) {
+      if (IsInitialized(*member)) {
+        return &*member;
+      }
+    }
+
+    // Common block may be initialized via initialized variables that are in an
+    // equivalence with the common block members.
+    for (const Fortran::semantics::EquivalenceSet &set :
+        common.owner().equivalenceSets()) {
+      for (const Fortran::semantics::EquivalenceObject &obj : set) {
+        if (!obj.symbol.test(
+                Fortran::semantics::Symbol::Flag::CompilerCreated)) {
+          if (FindCommonBlockContaining(obj.symbol) == &common &&
+              IsInitialized(obj.symbol)) {
+            return &obj.symbol;
+          }
+        }
+      }
+    }
+    return nullptr;
+  }
+  std::map<SourceName, CommonBlockInfo> commonBlocks_;
+};
+
 SemanticsContext::SemanticsContext(
     const common::IntrinsicTypeDefaultKinds &defaultKinds,
     const common::LanguageFeatureControl &languageFeatures,
@@ -469,4 +572,19 @@ static void PutIndent(llvm::raw_ostream &os, int indent) {
     os << "  ";
   }
 }
+
+void SemanticsContext::MapCommonBlockAndCheckConflicts(const Symbol &common) {
+  if (!commonBlockMap_) {
+    commonBlockMap_ = std::make_unique<CommonBlockMap>();
+  }
+  commonBlockMap_->MapCommonBlockAndCheckConflicts(*this, common);
+}
+
+CommonBlockList SemanticsContext::GetCommonBlocks() const {
+  if (commonBlockMap_) {
+    return commonBlockMap_->GetCommonBlocks();
+  }
+  return {};
+}
+
 } // namespace Fortran::semantics

flang/test/Lower/common-block-2.f90

@@ -0,0 +1,37 @@
+! RUN: bbc %s -o - | FileCheck %s
+
+! Test support of non standard features regarding common blocks:
+! - A named common that appears with different storage sizes
+! - A blank common that is initialized
+! - A common block that is initialized outside of a BLOCK DATA.
+
+! CHECK-LABEL: fir.global @_QB : tuple<i32, !fir.array<8xi8>> {
+! CHECK:  %[[undef:.*]] = fir.undefined tuple<i32, !fir.array<8xi8>>
+! CHECK:  %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple<i32, !fir.array<8xi8>>, i32) -> tuple<i32, !fir.array<8xi8>>
+! CHECK:  fir.has_value %[[init]] : tuple<i32, !fir.array<8xi8>>
+
+! CHECK-LABEL: fir.global @_QBa : tuple<i32, !fir.array<8xi8>> {
+! CHECK:  %[[undef:.*]] = fir.undefined tuple<i32, !fir.array<8xi8>>
+! CHECK:  %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple<i32, !fir.array<8xi8>>, i32) -> tuple<i32, !fir.array<8xi8>>
+! CHECK:  fir.has_value %[[init]] : tuple<i32, !fir.array<8xi8>>
+
+
+subroutine first_appearance
+  real :: x, y, xa, ya
+  common // x, y
+  common /a/ xa, ya
+  call foo(x, xa)
+end subroutine
+
+subroutine second_appearance
+  real :: x, y, z, xa, ya, za
+  common // x, y, z
+  common /a/ xa, ya, za
+  call foo(x, xa)
+end subroutine
+
+subroutine third_appearance
+  integer :: x = 42, xa = 42
+  common // x
+  common /a/ xa
+end subroutine

flang/test/Lower/common-block.f90

@@ -1,11 +1,11 @@
 ! RUN: bbc %s -o - | tco | FileCheck %s
 
 ! CHECK: @_QB = common global [8 x i8] zeroinitializer
+! CHECK: @_QBrien = common global [1 x i8] zeroinitializer
+! CHECK: @_QBwith_empty_equiv = common global [8 x i8] zeroinitializer
 ! CHECK: @_QBx = global { float, float } { float 1.0{{.*}}, float 2.0{{.*}} }
 ! CHECK: @_QBy = common global [12 x i8] zeroinitializer
 ! CHECK: @_QBz = global { i32, [4 x i8], float } { i32 42, [4 x i8] undef, float 3.000000e+00 }
-! CHECK: @_QBrien = common global [1 x i8] zeroinitializer
-! CHECK: @_QBwith_empty_equiv = common global [8 x i8] zeroinitializer
 
 ! CHECK-LABEL: _QPs0
 subroutine s0

flang/test/Lower/module_definition.f90

@@ -3,6 +3,27 @@
 ! Test lowering of module that defines data that is otherwise not used
 ! in this file.
 
+! Module defines variable in common block without initializer
+module modCommonNoInit1
+  ! Module variable is in blank common
+  real :: x_blank
+  common // x_blank
+  ! Module variable is in named common, no init
+  real :: x_named1
+  common /named1/ x_named1
+end module
+! CHECK-LABEL: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+! CHECK-LABEL: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+
+! Module defines variable in common block with initialization
+module modCommonInit1
+  integer :: i_named2 = 42
+  common /named2/ i_named2
+end module
+! CHECK-LABEL: fir.global @_QBnamed2 : tuple<i32> {
+  ! CHECK: %[[init:.*]] = fir.insert_value %{{.*}}, %c42{{.*}}, [0 : index] : (tuple<i32>, i32) -> tuple<i32>
+  ! CHECK: fir.has_value %[[init]] : tuple<i32>
+
 ! Module m1 defines simple data
 module m1
   real :: x
@@ -29,27 +50,6 @@ end module
   ! CHECK: %[[v3:.*]] = fir.insert_on_range %2, %c0{{.*}} from (5) to (9) : (!fir.array<10xi32>, i32) -> !fir.array<10xi32>
   ! CHECK: fir.has_value %[[v3]] : !fir.array<10xi32>
 
-! Module defines variable in common block without initializer
-module modCommonNoInit1
-  ! Module variable is in blank common
-  real :: x_blank
-  common // x_blank
-  ! Module variable is in named common, no init
-  real :: x_named1
-  common /named1/ x_named1
-end module
-! CHECK-LABEL: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8>
-! CHECK-LABEL: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8>
-
-! Module defines variable in common block with initialization
-module modCommonInit1
-  integer :: i_named2 = 42
-  common /named2/ i_named2
-end module
-! CHECK-LABEL: fir.global @_QBnamed2 : tuple<i32> {
-  ! CHECK: %[[init:.*]] = fir.insert_value %{{.*}}, %c42{{.*}}, [0 : index] : (tuple<i32>, i32) -> tuple<i32>
-  ! CHECK: fir.has_value %[[init]] : tuple<i32>
-
 ! Test defining two module variables whose initializers depend on each others
 ! addresses.
 module global_init_depending_on_each_other_address

flang/test/Lower/module_use.f90

@@ -5,6 +5,10 @@
 ! The modules are defined in module_definition.f90
 ! The first runs ensures the module file is generated.
 
+! CHECK: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+! CHECK-NEXT: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+! CHECK-NEXT: fir.global common @_QBnamed2(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+
 ! CHECK-LABEL: func @_QPm1use()
 real function m1use()
   use m1
@@ -37,6 +41,3 @@ end function
 
 ! CHECK-DAG: fir.global @_QMm1Ex : f32
 ! CHECK-DAG: fir.global @_QMm1Ey : !fir.array<100xi32>
-! CHECK-DAG: fir.global common @_QBnamed2(dense<0> : vector<4xi8>) : !fir.array<4xi8>
-! CHECK-DAG: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8>
-! CHECK-DAG: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8>

flang/test/Lower/pointer-initial-target-2.f90

@@ -5,6 +5,52 @@
 ! More complete tests regarding the initial data target expression
 ! are done in pointer-initial-target.f90.
 
+! Test pointer initial data target with pointer in common blocks
+block data
+  real, pointer :: p
+  real, save, target :: b
+  common /a/ p
+  data p /b/
+! CHECK-LABEL: fir.global @_QBa : tuple<!fir.box<!fir.ptr<f32>>>
+  ! CHECK: %[[undef:.*]] = fir.undefined tuple<!fir.box<!fir.ptr<f32>>>
+  ! CHECK: %[[b:.*]] = fir.address_of(@_QEb) : !fir.ref<f32>
+  ! CHECK: %[[box:.*]] = fir.embox %[[b]] : (!fir.ref<f32>) -> !fir.box<!fir.ptr<f32>>
+  ! CHECK: %[[a:.*]] = fir.insert_value %[[undef]], %[[box]], [0 : index] : (tuple<!fir.box<!fir.ptr<f32>>>, !fir.box<!fir.ptr<f32>>) -> tuple<!fir.box<!fir.ptr<f32>>>
+  ! CHECK: fir.has_value %[[a]] : tuple<!fir.box<!fir.ptr<f32>>>
+end block data
+
+! Test two common depending on each others because of initial data
+! targets
+block data tied
+  real, target :: x1 = 42
+  real, target :: x2 = 43
+  real, pointer :: p1 => x2
+  real, pointer :: p2 => x1
+  common /c1/ x1, p1
+  common /c2/ x2, p2
+! CHECK-LABEL: fir.global @_QBc1 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
+  ! CHECK: fir.address_of(@_QBc2) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
+! CHECK-LABEL: fir.global @_QBc2 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
+  ! CHECK: fir.address_of(@_QBc1) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
+end block data
+
+! Test pointer in a common with initial target in the same common.
+block data snake
+  integer, target :: b = 42
+  integer, pointer :: p => b
+  common /snake/ p, b
+! CHECK-LABEL: fir.global @_QBsnake : tuple<!fir.box<!fir.ptr<i32>>, i32>
+  ! CHECK: %[[tuple0:.*]] = fir.undefined tuple<!fir.box<!fir.ptr<i32>>, i32>
+  ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QBsnake) : !fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>
+  ! CHECK: %[[byteView:.*]] = fir.convert %[[snakeAddr:.*]] : (!fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>) -> !fir.ref<!fir.array<?xi8>>
+  ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[byteView]], %c24{{.*}} : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
+  ! CHECK: %[[bAddr:.*]] = fir.convert %[[coor]] : (!fir.ref<i8>) -> !fir.ref<i32>
+  ! CHECK: %[[box:.*]] = fir.embox %[[bAddr]] : (!fir.ref<i32>) -> !fir.box<!fir.ptr<i32>>
+  ! CHECK: %[[tuple1:.*]] = fir.insert_value %[[tuple0]], %[[box]], [0 : index] : (tuple<!fir.box<!fir.ptr<i32>>, i32>, !fir.box<!fir.ptr<i32>>) -> tuple<!fir.box<!fir.ptr<i32>>, i32>
+  ! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple1]], %c42{{.*}}, [1 : index] : (tuple<!fir.box<!fir.ptr<i32>>, i32>, i32) -> tuple<!fir.box<!fir.ptr<i32>>, i32>
+  ! CHECK: fir.has_value %[[tuple2]] : tuple<!fir.box<!fir.ptr<i32>>, i32>
+end block data
+
 ! Test pointer initial data target in modules
 module some_mod
   real, target :: x(100)
@@ -31,49 +77,3 @@ module some_mod_2
   ! CHECK: %[[box:.*]] = fir.embox %[[y]](%[[shape]]) : (!fir.ref<!fir.array<200xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
   ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
 end module
-
-! Test pointer initial data target with pointer in common blocks
-block data
-  real, pointer :: p
-  real, save, target :: b
-  common /a/ p
-  data p /b/
-! CHECK-LABEL: fir.global @_QBa : tuple<!fir.box<!fir.ptr<f32>>>
-  ! CHECK: %[[undef:.*]] = fir.undefined tuple<!fir.box<!fir.ptr<f32>>>
-  ! CHECK: %[[b:.*]] = fir.address_of(@_QEb) : !fir.ref<f32>
-  ! CHECK: %[[box:.*]] = fir.embox %[[b]] : (!fir.ref<f32>) -> !fir.box<!fir.ptr<f32>>
-  ! CHECK: %[[a:.*]] = fir.insert_value %[[undef]], %[[box]], [0 : index] : (tuple<!fir.box<!fir.ptr<f32>>>, !fir.box<!fir.ptr<f32>>) -> tuple<!fir.box<!fir.ptr<f32>>>
-  ! CHECK: fir.has_value %[[a]] : tuple<!fir.box<!fir.ptr<f32>>>
-end block data
-
-! Test pointer in a common with initial target in the same common.
-block data snake
-  integer, target :: b = 42
-  integer, pointer :: p => b
-  common /snake/ p, b
-! CHECK-LABEL: fir.global @_QBsnake : tuple<!fir.box<!fir.ptr<i32>>, i32>
-  ! CHECK: %[[tuple0:.*]] = fir.undefined tuple<!fir.box<!fir.ptr<i32>>, i32>
-  ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QBsnake) : !fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>
-  ! CHECK: %[[byteView:.*]] = fir.convert %[[snakeAddr:.*]] : (!fir.ref<tuple<!fir.box<!fir.ptr<i32>>, i32>>) -> !fir.ref<!fir.array<?xi8>>
-  ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[byteView]], %c24{{.*}} : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
-  ! CHECK: %[[bAddr:.*]] = fir.convert %[[coor]] : (!fir.ref<i8>) -> !fir.ref<i32>
-  ! CHECK: %[[box:.*]] = fir.embox %[[bAddr]] : (!fir.ref<i32>) -> !fir.box<!fir.ptr<i32>>
-  ! CHECK: %[[tuple1:.*]] = fir.insert_value %[[tuple0]], %[[box]], [0 : index] : (tuple<!fir.box<!fir.ptr<i32>>, i32>, !fir.box<!fir.ptr<i32>>) -> tuple<!fir.box<!fir.ptr<i32>>, i32>
-  ! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple1]], %c42{{.*}}, [1 : index] : (tuple<!fir.box<!fir.ptr<i32>>, i32>, i32) -> tuple<!fir.box<!fir.ptr<i32>>, i32>
-  ! CHECK: fir.has_value %[[tuple2]] : tuple<!fir.box<!fir.ptr<i32>>, i32>
-end block data
-
-! Test two common depending on each others because of initial data
-! targets
-block data tied
-  real, target :: x1 = 42
-  real, target :: x2 = 43
-  real, pointer :: p1 => x2
-  real, pointer :: p2 => x1
-  common /c1/ x1, p1
-  common /c2/ x2, p2
-! CHECK-LABEL: fir.global @_QBc1 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
-  ! CHECK: fir.address_of(@_QBc2) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
-! CHECK-LABEL: fir.global @_QBc2 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
-  ! CHECK: fir.address_of(@_QBc1) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
-end block data

flang/test/Semantics/common-blocks-warn.f90

@@ -0,0 +1,16 @@
+! RUN: %flang -fsyntax-only 2>&1 %s | FileCheck %s
+
+! Test that a warning is emitted when a named common block appears in
+! several scopes with a different storage size.
+
+subroutine size_1
+  common x, y
+  common /c/ xc, yc
+end subroutine
+
+subroutine size_2
+  ! OK, blank common size may always differ.
+  common x, y, z
+  !CHECK: portability: A named COMMON block should have the same size everywhere it appears (12 bytes here)
+  common /c/ xc, yc, zc
+end subroutine

flang/test/Semantics/common-blocks.f90

@@ -0,0 +1,23 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+! Test check that enforce that a common block is initialized
+! only once in a file.
+
+subroutine init_1
+  common x, y
+  common /a/ xa, ya
+  common /b/ xb, yb
+  !CHECK: portability: Blank COMMON object 'x' in a DATA statement is not standard
+  data x /42./, xa /42./, yb/42./
+end subroutine
+
+subroutine init_conflict
+  !ERROR: Multiple initialization of COMMON block //
+  common x, y
+  !ERROR: Multiple initialization of COMMON block /a/
+  common /a/ xa, ya
+  common /b/ xb, yb
+  equivalence (yb, yb_eq)
+  !ERROR: Multiple initialization of COMMON block /b/
+  data x /66./, xa /66./, yb_eq /66./
+end subroutine

flang/test/Semantics/resolve42.f90

@@ -83,7 +83,7 @@ module m11
   end type
   type(t2) :: x2
   !ERROR: Derived type variable 'x2' may not appear in a COMMON block due to ALLOCATABLE component
-  common x2
+  common /c2/ x2
 end
 
 module m12
@@ -98,7 +98,7 @@ module m12
   end type
   type(t2) :: x2
   !ERROR: Derived type variable 'x2' may not appear in a COMMON block due to component with default initialization
-  common x2
+  common /c3/ x2
 end
 
 subroutine s13