[flang] Lower allocatable assignment for scalar

[clementval]

Summary

Add lowering for simple assignement on allocatable
scalars.

This patch is part of the upstreaming effort from fir-dev branch.

Depends on D120483

[PeteSteinfeld]

There's something odd about this patch. When I try to download it, I don't get the same files that appear on the Phabricator GUI. For example, .../flang/include/flang/Lower/Allocatable.h is missing.

I notice that your comments say that this patch depends on another patch. Perhaps that's related to my problem.

[clementval]

In D120488#3343343, @PeteSteinfeld wrote:

There's something odd about this patch. When I try to download it, I don't get the same files that appear on the Phabricator GUI. For example, .../flang/include/flang/Lower/Allocatable.h is missing.

I notice that your comments say that this patch depends on another patch. Perhaps that's related to my problem.

It probably need a rebase. I'll do it now.

[clementval]

Rebase

[PeteSteinfeld]

I saw one small misspelling in .../flang/include/flang/Lower/Allocatable.h.

Otherwise, all builds and tests correctly and looks good.

flang/include/flang/Lower/Allocatable.h

39

I think you mean "disassociated".

flang/include/flang/Lower/AbstractConverter.h

virtual fir::ExtendedValue genExprValue(const SomeExpr &, StatementContext &,
                                           mlir::Location *loc = nullptr) = 0;
   /// Generate the computations of the expression, someExpr, to produce a value
   fir::ExtendedValue genExprValue(const SomeExpr *someExpr,
                                   StatementContext &stmtCtx,
                                   mlir::Location loc) {
     return genExprValue(*someExpr, stmtCtx, &loc);
   }
 
+  /// Generate the address of the box describing the variable designated
+  /// by the expression. The expression must be an allocatable or pointer
+  /// designator.
+  virtual fir::MutableBoxValue genExprMutableBox(mlir::Location loc,
+                                                 const SomeExpr &) = 0;
+
   /// Get FoldingContext that is required for some expression
   /// analysis.
   virtual Fortran::evaluate::FoldingContext &getFoldingContext() = 0;
 
   /// Host associated variables are grouped as a tuple. This returns that value,
   /// which is itself a reference. Use bindTuple() to set this value.
   virtual mlir::Value hostAssocTupleValue() = 0;
 

flang/include/flang/Lower/Allocatable.h

+//===-- Allocatable.h -- Allocatable statements lowering ------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_ALLOCATABLE_H
+#define FORTRAN_LOWER_ALLOCATABLE_H
+
+#include "flang/Optimizer/Builder/MutableBox.h"
+#include "llvm/ADT/StringRef.h"
+
+namespace mlir {
+class Value;
+class ValueRange;
+class Location;
+} // namespace mlir
+
+namespace fir {
+class MutableBoxValue;
+} // namespace fir
+
+namespace Fortran::lower {
+class AbstractConverter;
+
+namespace pft {
+struct Variable;
+}
+
+/// Create a MutableBoxValue for an allocatable or pointer entity.
+/// If the variables is a local variable that is not a dummy, it will be
+/// initialized to unallocated/diassociated status.
+fir::MutableBoxValue createMutableBox(Fortran::lower::AbstractConverter &,
+                                      mlir::Location,
+                                      const Fortran::lower::pft::Variable &var,
+                                      mlir::Value boxAddr,
+                                      mlir::ValueRange nonDeferredParams);
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_ALLOCATABLE_H

flang/include/flang/Lower/BoxAnalyzer.h

+//===-- BoxAnalyzer.h -------------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_BOXANALYZER_H
+#define FORTRAN_LOWER_BOXANALYZER_H
+
+#include "flang/Evaluate/fold.h"
+#include "flang/Lower/Support/Utils.h"
+#include "flang/Optimizer/Dialect/FIRType.h"
+#include "flang/Optimizer/Support/Matcher.h"
+
+namespace Fortran::lower {
+
+//===----------------------------------------------------------------------===//
+// Classifications of a symbol.
+//
+// Each classification is a distinct class and can be used in pattern matching.
+//===----------------------------------------------------------------------===//
+
+namespace details {
+
+using FromBox = std::monostate;
+
+/// Base class for all box analysis results.
+struct ScalarSym {
+  ScalarSym(const Fortran::semantics::Symbol &sym) : sym{&sym} {}
+  ScalarSym &operator=(const ScalarSym &) = default;
+
+  const Fortran::semantics::Symbol &symbol() const { return *sym; }
+
+  static constexpr bool staticSize() { return true; }
+  static constexpr bool isChar() { return false; }
+  static constexpr bool isArray() { return false; }
+
+private:
+  const Fortran::semantics::Symbol *sym;
+};
+
+/// Scalar of dependent type CHARACTER, constant LEN.
+struct ScalarStaticChar : ScalarSym {
+  ScalarStaticChar(const Fortran::semantics::Symbol &sym, int64_t len)
+      : ScalarSym{sym}, len{len} {}
+
+  int64_t charLen() const { return len; }
+
+  static constexpr bool isChar() { return true; }
+
+private:
+  int64_t len;
+};
+
+/// Scalar of dependent type Derived, constant LEN(s).
+struct ScalarStaticDerived : ScalarSym {
+  ScalarStaticDerived(const Fortran::semantics::Symbol &sym,
+                      llvm::SmallVectorImpl<int64_t> &&lens)
+      : ScalarSym{sym}, lens{std::move(lens)} {}
+
+private:
+  llvm::SmallVector<int64_t> lens;
+};
+
+/// Scalar of dependent type CHARACTER, dynamic LEN.
+struct ScalarDynamicChar : ScalarSym {
+  ScalarDynamicChar(const Fortran::semantics::Symbol &sym,
+                    const Fortran::lower::SomeExpr &len)
+      : ScalarSym{sym}, len{len} {}
+  ScalarDynamicChar(const Fortran::semantics::Symbol &sym)
+      : ScalarSym{sym}, len{FromBox{}} {}
+
+  llvm::Optional<Fortran::lower::SomeExpr> charLen() const {
+    if (auto *l = std::get_if<Fortran::lower::SomeExpr>(&len))
+      return {*l};
+    return llvm::None;
+  }
+
+  static constexpr bool staticSize() { return false; }
+  static constexpr bool isChar() { return true; }
+
+private:
+  std::variant<FromBox, Fortran::lower::SomeExpr> len;
+};
+
+/// Scalar of dependent type Derived, dynamic LEN(s).
+struct ScalarDynamicDerived : ScalarSym {
+  ScalarDynamicDerived(const Fortran::semantics::Symbol &sym,
+                       llvm::SmallVectorImpl<Fortran::lower::SomeExpr> &&lens)
+      : ScalarSym{sym}, lens{std::move(lens)} {}
+
+private:
+  llvm::SmallVector<Fortran::lower::SomeExpr> lens;
+};
+
+struct LBoundsAndShape {
+  LBoundsAndShape(llvm::SmallVectorImpl<int64_t> &&lbounds,
+                  llvm::SmallVectorImpl<int64_t> &&shapes)
+      : lbounds{std::move(lbounds)}, shapes{std::move(shapes)} {}
+
+  static constexpr bool staticSize() { return true; }
+  static constexpr bool isArray() { return true; }
+  bool lboundAllOnes() const {
+    return llvm::all_of(lbounds, [](int64_t v) { return v == 1; });
+  }
+
+  llvm::SmallVector<int64_t> lbounds;
+  llvm::SmallVector<int64_t> shapes;
+};
+
+/// Array of T with statically known origin (lbounds) and shape.
+struct StaticArray : ScalarSym, LBoundsAndShape {
+  StaticArray(const Fortran::semantics::Symbol &sym,
+              llvm::SmallVectorImpl<int64_t> &&lbounds,
+              llvm::SmallVectorImpl<int64_t> &&shapes)
+      : ScalarSym{sym}, LBoundsAndShape{std::move(lbounds), std::move(shapes)} {
+  }
+
+  static constexpr bool staticSize() { return LBoundsAndShape::staticSize(); }
+};
+
+struct DynamicBound {
+  DynamicBound(
+      llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+      : bounds{std::move(bounds)} {}
+
+  static constexpr bool staticSize() { return false; }
+  static constexpr bool isArray() { return true; }
+  bool lboundAllOnes() const {
+    return llvm::all_of(bounds, [](const Fortran::semantics::ShapeSpec *p) {
+      if (auto low = p->lbound().GetExplicit())
+        if (auto lb = Fortran::evaluate::ToInt64(*low))
+          return *lb == 1;
+      return false;
+    });
+  }
+
+  llvm::SmallVector<const Fortran::semantics::ShapeSpec *> bounds;
+};
+
+/// Array of T with dynamic origin and/or shape.
+struct DynamicArray : ScalarSym, DynamicBound {
+  DynamicArray(
+      const Fortran::semantics::Symbol &sym,
+      llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+      : ScalarSym{sym}, DynamicBound{std::move(bounds)} {}
+
+  static constexpr bool staticSize() { return DynamicBound::staticSize(); }
+};
+
+/// Array of CHARACTER with statically known LEN, origin, and shape.
+struct StaticArrayStaticChar : ScalarStaticChar, LBoundsAndShape {
+  StaticArrayStaticChar(const Fortran::semantics::Symbol &sym, int64_t len,
+                        llvm::SmallVectorImpl<int64_t> &&lbounds,
+                        llvm::SmallVectorImpl<int64_t> &&shapes)
+      : ScalarStaticChar{sym, len}, LBoundsAndShape{std::move(lbounds),
+                                                    std::move(shapes)} {}
+
+  static constexpr bool staticSize() {
+    return ScalarStaticChar::staticSize() && LBoundsAndShape::staticSize();
+  }
+};
+
+/// Array of CHARACTER with dynamic LEN but constant origin, shape.
+struct StaticArrayDynamicChar : ScalarDynamicChar, LBoundsAndShape {
+  StaticArrayDynamicChar(const Fortran::semantics::Symbol &sym,
+                         const Fortran::lower::SomeExpr &len,
+                         llvm::SmallVectorImpl<int64_t> &&lbounds,
+                         llvm::SmallVectorImpl<int64_t> &&shapes)
+      : ScalarDynamicChar{sym, len}, LBoundsAndShape{std::move(lbounds),
+                                                     std::move(shapes)} {}
+  StaticArrayDynamicChar(const Fortran::semantics::Symbol &sym,
+                         llvm::SmallVectorImpl<int64_t> &&lbounds,
+                         llvm::SmallVectorImpl<int64_t> &&shapes)
+      : ScalarDynamicChar{sym}, LBoundsAndShape{std::move(lbounds),
+                                                std::move(shapes)} {}
+
+  static constexpr bool staticSize() {
+    return ScalarDynamicChar::staticSize() && LBoundsAndShape::staticSize();
+  }
+};
+
+/// Array of CHARACTER with constant LEN but dynamic origin, shape.
+struct DynamicArrayStaticChar : ScalarStaticChar, DynamicBound {
+  DynamicArrayStaticChar(
+      const Fortran::semantics::Symbol &sym, int64_t len,
+      llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+      : ScalarStaticChar{sym, len}, DynamicBound{std::move(bounds)} {}
+
+  static constexpr bool staticSize() {
+    return ScalarStaticChar::staticSize() && DynamicBound::staticSize();
+  }
+};
+
+/// Array of CHARACTER with dynamic LEN, origin, and shape.
+struct DynamicArrayDynamicChar : ScalarDynamicChar, DynamicBound {
+  DynamicArrayDynamicChar(
+      const Fortran::semantics::Symbol &sym,
+      const Fortran::lower::SomeExpr &len,
+      llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+      : ScalarDynamicChar{sym, len}, DynamicBound{std::move(bounds)} {}
+  DynamicArrayDynamicChar(
+      const Fortran::semantics::Symbol &sym,
+      llvm::SmallVectorImpl<const Fortran::semantics::ShapeSpec *> &&bounds)
+      : ScalarDynamicChar{sym}, DynamicBound{std::move(bounds)} {}
+
+  static constexpr bool staticSize() {
+    return ScalarDynamicChar::staticSize() && DynamicBound::staticSize();
+  }
+};
+
+// TODO: Arrays of derived types with LEN(s)...
+
+} // namespace details
+
+inline bool symIsChar(const Fortran::semantics::Symbol &sym) {
+  return sym.GetType()->category() ==
+         Fortran::semantics::DeclTypeSpec::Character;
+}
+
+inline bool symIsArray(const Fortran::semantics::Symbol &sym) {
+  const auto *det =
+      sym.GetUltimate().detailsIf<Fortran::semantics::ObjectEntityDetails>();
+  return det && det->IsArray();
+}
+
+inline bool isExplicitShape(const Fortran::semantics::Symbol &sym) {
+  const auto *det =
+      sym.GetUltimate().detailsIf<Fortran::semantics::ObjectEntityDetails>();
+  return det && det->IsArray() && det->shape().IsExplicitShape();
+}
+
+//===----------------------------------------------------------------------===//
+// Perform analysis to determine a box's parameter values
+//===----------------------------------------------------------------------===//
+
+/// Analyze a symbol, classify it as to whether it just a scalar, a CHARACTER
+/// scalar, an array entity, a combination thereof, and whether the LEN, shape,
+/// and lbounds are constant or not.
+class BoxAnalyzer : public fir::details::matcher<BoxAnalyzer> {
+public:
+  // Analysis default state
+  using None = std::monostate;
+
+  using ScalarSym = details::ScalarSym;
+  using ScalarStaticChar = details::ScalarStaticChar;
+  using ScalarDynamicChar = details::ScalarDynamicChar;
+  using StaticArray = details::StaticArray;
+  using DynamicArray = details::DynamicArray;
+  using StaticArrayStaticChar = details::StaticArrayStaticChar;
+  using StaticArrayDynamicChar = details::StaticArrayDynamicChar;
+  using DynamicArrayStaticChar = details::DynamicArrayStaticChar;
+  using DynamicArrayDynamicChar = details::DynamicArrayDynamicChar;
+  // TODO: derived types
+
+  using VT = std::variant<None, ScalarSym, ScalarStaticChar, ScalarDynamicChar,
+                          StaticArray, DynamicArray, StaticArrayStaticChar,
+                          StaticArrayDynamicChar, DynamicArrayStaticChar,
+                          DynamicArrayDynamicChar>;
+
+  //===--------------------------------------------------------------------===//
+  // Constructor
+  //===--------------------------------------------------------------------===//
+
+  BoxAnalyzer() : box{None{}} {}
+
+  operator bool() const { return !std::holds_alternative<None>(box); }
+
+  bool isTrivial() const { return std::holds_alternative<ScalarSym>(box); }
+
+  /// Returns true for any sort of CHARACTER.
+  bool isChar() const {
+    return match([](const ScalarStaticChar &) { return true; },
+                 [](const ScalarDynamicChar &) { return true; },
+                 [](const StaticArrayStaticChar &) { return true; },
+                 [](const StaticArrayDynamicChar &) { return true; },
+                 [](const DynamicArrayStaticChar &) { return true; },
+                 [](const DynamicArrayDynamicChar &) { return true; },
+                 [](const auto &) { return false; });
+  }
+
+  /// Returns true for any sort of array.
+  bool isArray() const {
+    return match([](const StaticArray &) { return true; },
+                 [](const DynamicArray &) { return true; },
+                 [](const StaticArrayStaticChar &) { return true; },
+                 [](const StaticArrayDynamicChar &) { return true; },
+                 [](const DynamicArrayStaticChar &) { return true; },
+                 [](const DynamicArrayDynamicChar &) { return true; },
+                 [](const auto &) { return false; });
+  }
+
+  /// Returns true iff this is an array with constant extents and lbounds. This
+  /// returns true for arrays of CHARACTER, even if the LEN is not a constant.
+  bool isStaticArray() const {
+    return match([](const StaticArray &) { return true; },
+                 [](const StaticArrayStaticChar &) { return true; },
+                 [](const StaticArrayDynamicChar &) { return true; },
+                 [](const auto &) { return false; });
+  }
+
+  bool isConstant() const {
+    return match(
+        [](const None &) -> bool {
+          llvm::report_fatal_error("internal: analysis failed");
+        },
+        [](const auto &x) { return x.staticSize(); });
+  }
+
+  llvm::Optional<int64_t> getCharLenConst() const {
+    using A = llvm::Optional<int64_t>;
+    return match(
+        [](const ScalarStaticChar &x) -> A { return {x.charLen()}; },
+        [](const StaticArrayStaticChar &x) -> A { return {x.charLen()}; },
+        [](const DynamicArrayStaticChar &x) -> A { return {x.charLen()}; },
+        [](const auto &) -> A { return llvm::None; });
+  }
+
+  llvm::Optional<Fortran::lower::SomeExpr> getCharLenExpr() const {
+    using A = llvm::Optional<Fortran::lower::SomeExpr>;
+    return match([](const ScalarDynamicChar &x) { return x.charLen(); },
+                 [](const StaticArrayDynamicChar &x) { return x.charLen(); },
+                 [](const DynamicArrayDynamicChar &x) { return x.charLen(); },
+                 [](const auto &) -> A { return llvm::None; });
+  }
+
+  /// Is the origin of this array the default of vector of `1`?
+  bool lboundIsAllOnes() const {
+    return match(
+        [&](const StaticArray &x) { return x.lboundAllOnes(); },
+        [&](const DynamicArray &x) { return x.lboundAllOnes(); },
+        [&](const StaticArrayStaticChar &x) { return x.lboundAllOnes(); },
+        [&](const StaticArrayDynamicChar &x) { return x.lboundAllOnes(); },
+        [&](const DynamicArrayStaticChar &x) { return x.lboundAllOnes(); },
+        [&](const DynamicArrayDynamicChar &x) { return x.lboundAllOnes(); },
+        [](const auto &) -> bool { llvm::report_fatal_error("not an array"); });
+  }
+
+  /// Get the static lbound values (the origin of the array).
+  llvm::ArrayRef<int64_t> staticLBound() const {
+    using A = llvm::ArrayRef<int64_t>;
+    return match([](const StaticArray &x) -> A { return x.lbounds; },
+                 [](const StaticArrayStaticChar &x) -> A { return x.lbounds; },
+                 [](const StaticArrayDynamicChar &x) -> A { return x.lbounds; },
+                 [](const auto &) -> A {
+                   llvm::report_fatal_error("does not have static lbounds");
+                 });
+  }
+
+  /// Get the static extents of the array.
+  llvm::ArrayRef<int64_t> staticShape() const {
+    using A = llvm::ArrayRef<int64_t>;
+    return match([](const StaticArray &x) -> A { return x.shapes; },
+                 [](const StaticArrayStaticChar &x) -> A { return x.shapes; },
+                 [](const StaticArrayDynamicChar &x) -> A { return x.shapes; },
+                 [](const auto &) -> A {
+                   llvm::report_fatal_error("does not have static shape");
+                 });
+  }
+
+  /// Get the dynamic bounds information of the array (both origin, shape).
+  llvm::ArrayRef<const Fortran::semantics::ShapeSpec *> dynamicBound() const {
+    using A = llvm::ArrayRef<const Fortran::semantics::ShapeSpec *>;
+    return match([](const DynamicArray &x) -> A { return x.bounds; },
+                 [](const DynamicArrayStaticChar &x) -> A { return x.bounds; },
+                 [](const DynamicArrayDynamicChar &x) -> A { return x.bounds; },
+                 [](const auto &) -> A {
+                   llvm::report_fatal_error("does not have bounds");
+                 });
+  }
+
+  /// Run the analysis on `sym`.
+  void analyze(const Fortran::semantics::Symbol &sym) {
+    if (symIsArray(sym)) {
+      bool isConstant = true;
+      llvm::SmallVector<int64_t> lbounds;
+      llvm::SmallVector<int64_t> shapes;
+      llvm::SmallVector<const Fortran::semantics::ShapeSpec *> bounds;
+      for (const Fortran::semantics::ShapeSpec &subs : getSymShape(sym)) {
+        bounds.push_back(&subs);
+        if (!isConstant)
+          continue;
+        if (auto low = subs.lbound().GetExplicit()) {
+          if (auto lb = Fortran::evaluate::ToInt64(*low)) {
+            lbounds.push_back(*lb); // origin for this dim
+            if (auto high = subs.ubound().GetExplicit()) {
+              if (auto ub = Fortran::evaluate::ToInt64(*high)) {
+                int64_t extent = *ub - *lb + 1;
+                shapes.push_back(extent < 0 ? 0 : extent);
+                continue;
+              }
+            } else if (subs.ubound().isStar()) {
+              shapes.push_back(fir::SequenceType::getUnknownExtent());
+              continue;
+            }
+          }
+        }
+        isConstant = false;
+      }
+
+      // sym : array<CHARACTER>
+      if (symIsChar(sym)) {
+        if (auto len = charLenConstant(sym)) {
+          if (isConstant)
+            box = StaticArrayStaticChar(sym, *len, std::move(lbounds),
+                                        std::move(shapes));
+          else
+            box = DynamicArrayStaticChar(sym, *len, std::move(bounds));
+          return;
+        }
+        if (auto var = charLenVariable(sym)) {
+          if (isConstant)
+            box = StaticArrayDynamicChar(sym, *var, std::move(lbounds),
+                                         std::move(shapes));
+          else
+            box = DynamicArrayDynamicChar(sym, *var, std::move(bounds));
+          return;
+        }
+        if (isConstant)
+          box = StaticArrayDynamicChar(sym, std::move(lbounds),
+                                       std::move(shapes));
+        else
+          box = DynamicArrayDynamicChar(sym, std::move(bounds));
+        return;
+      }
+
+      // sym : array<other>
+      if (isConstant)
+        box = StaticArray(sym, std::move(lbounds), std::move(shapes));
+      else
+        box = DynamicArray(sym, std::move(bounds));
+      return;
+    }
+
+    // sym : CHARACTER
+    if (symIsChar(sym)) {
+      if (auto len = charLenConstant(sym))
+        box = ScalarStaticChar(sym, *len);
+      else if (auto var = charLenVariable(sym))
+        box = ScalarDynamicChar(sym, *var);
+      else
+        box = ScalarDynamicChar(sym);
+      return;
+    }
+
+    // sym : other
+    box = ScalarSym(sym);
+  }
+
+  const VT &matchee() const { return box; }
+
+private:
+  // Get the shape of a symbol.
+  const Fortran::semantics::ArraySpec &
+  getSymShape(const Fortran::semantics::Symbol &sym) {
+    return sym.GetUltimate()
+        .get<Fortran::semantics::ObjectEntityDetails>()
+        .shape();
+  }
+
+  // Get the constant LEN of a CHARACTER, if it exists.
+  llvm::Optional<int64_t>
+  charLenConstant(const Fortran::semantics::Symbol &sym) {
+    if (llvm::Optional<Fortran::lower::SomeExpr> expr = charLenVariable(sym))
+      if (std::optional<int64_t> asInt = Fortran::evaluate::ToInt64(*expr)) {
+        // Length is max(0, *asInt) (F2018 7.4.4.2 point 5.).
+        if (*asInt < 0)
+          return 0;
+        return *asInt;
+      }
+    return llvm::None;
+  }
+
+  // Get the `SomeExpr` that describes the CHARACTER's LEN.
+  llvm::Optional<Fortran::lower::SomeExpr>
+  charLenVariable(const Fortran::semantics::Symbol &sym) {
+    const Fortran::semantics::ParamValue &lenParam =
+        sym.GetType()->characterTypeSpec().length();
+    if (Fortran::semantics::MaybeIntExpr expr = lenParam.GetExplicit())
+      return {Fortran::evaluate::AsGenericExpr(std::move(*expr))};
+    // For assumed length parameters, the length comes from the initialization
+    // expression.
+    if (sym.attrs().test(Fortran::semantics::Attr::PARAMETER))
+      if (const auto *objectDetails =
+              sym.GetUltimate()
+                  .detailsIf<Fortran::semantics::ObjectEntityDetails>())
+        if (objectDetails->init())
+          if (const auto *charExpr = std::get_if<
+                  Fortran::evaluate::Expr<Fortran::evaluate::SomeCharacter>>(
+                  &objectDetails->init()->u))
+            if (Fortran::semantics::MaybeSubscriptIntExpr expr =
+                    charExpr->LEN())
+              return {Fortran::evaluate::AsGenericExpr(std::move(*expr))};
+    return llvm::None;
+  }
+
+  VT box;
+}; // namespace Fortran::lower
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_BOXANALYZER_H

flang/include/flang/Lower/ConvertExpr.h

 
 /// Create an extended expression address.
 fir::ExtendedValue createSomeExtendedAddress(mlir::Location loc,
                                              AbstractConverter &converter,
                                              const SomeExpr &expr,
                                              SymMap &symMap,
                                              StatementContext &stmtCtx);
 
+/// Create the address of the box.
+/// \p expr must be the designator of an allocatable/pointer entity.
+fir::MutableBoxValue createMutableBox(mlir::Location loc,
+                                      AbstractConverter &converter,
+                                      const SomeExpr &expr, SymMap &symMap);
+
 /// Lower a subroutine call. This handles both elemental and non elemental
 /// subroutines. \p isUserDefAssignment must be set if this is called in the
 /// context of a user defined assignment. For subroutines with alternate
 /// returns, the returned value indicates which label the code should jump to.
 /// The returned value is null otherwise.
 mlir::Value createSubroutineCall(AbstractConverter &converter,
                                  const evaluate::ProcedureRef &call,
                                  SymMap &symMap, StatementContext &stmtCtx);

flang/include/flang/Lower/ConvertVariable.h

 ///
 /// Instantiation of pft::Variable in FIR/MLIR.
 ///
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_LOWER_CONVERT_VARIABLE_H
 #define FORTRAN_LOWER_CONVERT_VARIABLE_H
 
+#include "mlir/IR/Value.h"
+
 namespace Fortran ::lower {
 class AbstractConverter;
 class CallerInterface;
+class StatementContext;
 class SymMap;
 namespace pft {
 struct Variable;
 }
 
 /// Instantiate variable \p var and add it to \p symMap.
 /// The AbstractConverter builder must be set.
 /// The AbstractConverter own symbol mapping is not used during the
 /// instantiation and can be different form \p symMap.
 void instantiateVariable(AbstractConverter &, const pft::Variable &var,
                          SymMap &symMap);
 
+/// 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
+/// instantiateVariable cannot be called.
+void mapSymbolAttributes(AbstractConverter &, const pft::Variable &, SymMap &,
+                         StatementContext &, mlir::Value preAlloc = {});
+
 /// Instantiate the variables that appear in the specification expressions
 /// of the result of a function call. The instantiated variables are added
 /// to \p symMap.
 void mapCallInterfaceSymbols(AbstractConverter &,
                              const Fortran::lower::CallerInterface &caller,
                              SymMap &symMap);
 
 } // namespace Fortran::lower
 #endif // FORTRAN_LOWER_CONVERT_VARIABLE_H

flang/include/flang/Optimizer/Builder/MutableBox.h

 //===-- MutableBox.h -- MutableBox utilities  -----------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H
 #define FORTRAN_OPTIMIZER_BUILDER_MUTABLEBOX_H
 
+#include "flang/Optimizer/Builder/BoxValue.h"
 #include "llvm/ADT/StringRef.h"
 
 namespace mlir {
 class Value;
 class ValueRange;
 class Type;
 class Location;
 } // namespace mlir

 /// Lower bounds are only used if the entity needs to be allocated, otherwise,
 /// the MutableBoxValue will keep its current lower bounds.
 /// If the MutableBoxValue is an array, the provided shape can be empty, in
 /// which case the MutableBoxValue must already be allocated at runtime and its
 /// shape and lower bounds will be kept. If \p shape is empty, only a length
 /// parameter mismatch can trigger a reallocation. See Fortran 10.2.1.3 point 3
 /// that this function is implementing for more details. The polymorphic
 /// requirements are not yet covered by this function.
-void genReallocIfNeeded(fir::FirOpBuilder &builder, mlir::Location loc,
+struct MutableBoxReallocation {
+  fir::ExtendedValue newValue;
+  mlir::Value oldAddress;
+  mlir::Value wasReallocated;
+  mlir::Value oldAddressWasAllocated;
+};
+
+MutableBoxReallocation genReallocIfNeeded(fir::FirOpBuilder &builder,
+                                          mlir::Location loc,
                                           const fir::MutableBoxValue &box,
-                        mlir::ValueRange lbounds, mlir::ValueRange shape,
+                                          mlir::ValueRange shape,
                                           mlir::ValueRange lengthParams);
 
+void finalizeRealloc(fir::FirOpBuilder &builder, mlir::Location loc,
+                     const fir::MutableBoxValue &box, mlir::ValueRange lbounds,
+                     bool takeLboundsIfRealloc,
+                     const MutableBoxReallocation &realloc);
+
 /// Finalize a mutable box if it is allocated or associated. This includes both
 /// calling the finalizer, if any, and deallocating the storage.
 void genFinalization(fir::FirOpBuilder &builder, mlir::Location loc,
                      const fir::MutableBoxValue &box);
 
 void genInlinedAllocation(fir::FirOpBuilder &builder, mlir::Location loc,
                           const fir::MutableBoxValue &box,
                           mlir::ValueRange lbounds, mlir::ValueRange extents,

flang/include/flang/Optimizer/Builder/Runtime/Stop.h

 //===-- Stop.h - generate stop runtime API calls ----------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_OPTIMIZER_BUILDER_RUNTIME_STOP_H
 #define FORTRAN_OPTIMIZER_BUILDER_RUNTIME_STOP_H
 
+namespace llvm {
+class StringRef;
+}
+
 namespace mlir {
 class Value;
 class Location;
 } // namespace mlir
 
 namespace fir {
 class FirOpBuilder;
 }
 
 namespace fir::runtime {
 
 /// Generate call to EXIT intrinsic runtime routine.
 void genExit(fir::FirOpBuilder &, mlir::Location, mlir::Value status);
 
+/// Generate call to crash the program with an error message when detecting
+/// an invalid situation at runtime.
+void genReportFatalUserError(fir::FirOpBuilder &, mlir::Location,
+                             llvm::StringRef message);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_STOP_H

flang/lib/Lower/Allocatable.cpp

+//===-- Allocatable.cpp -- Allocatable statements lowering ----------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Lower/Allocatable.h"
+#include "flang/Evaluate/tools.h"
+#include "flang/Lower/AbstractConverter.h"
+#include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/Runtime.h"
+#include "flang/Lower/StatementContext.h"
+#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
+#include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/Dialect/FIROpsSupport.h"
+#include "flang/Optimizer/Support/FatalError.h"
+#include "flang/Parser/parse-tree.h"
+#include "flang/Semantics/tools.h"
+#include "flang/Semantics/type.h"
+#include "llvm/Support/CommandLine.h"
+
+/// By default fir memory operation fir::AllocMemOp/fir::FreeMemOp are used.
+/// This switch allow forcing the use of runtime and descriptors for everything.
+/// This is mainly intended as a debug switch.
+static llvm::cl::opt<bool> useAllocateRuntime(
+    "use-alloc-runtime",
+    llvm::cl::desc("Lower allocations to fortran runtime calls"),
+    llvm::cl::init(false));
+/// Switch to force lowering of allocatable and pointers to descriptors in all
+/// cases for debug purposes.
+static llvm::cl::opt<bool> useDescForMutableBox(
+    "use-desc-for-alloc",
+    llvm::cl::desc("Always use descriptors for POINTER and ALLOCATABLE"),
+    llvm::cl::init(false));
+
+//===----------------------------------------------------------------------===//
+// MutableBoxValue creation implementation
+//===----------------------------------------------------------------------===//
+
+/// Is this symbol a pointer to a pointer array that does not have the
+/// CONTIGUOUS attribute ?
+static inline bool
+isNonContiguousArrayPointer(const Fortran::semantics::Symbol &sym) {
+  return Fortran::semantics::IsPointer(sym) && sym.Rank() != 0 &&
+         !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS);
+}
+
+/// Is this a local procedure symbol in a procedure that contains internal
+/// procedures ?
+static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) {
+  const Fortran::semantics::Scope &owner = sym.owner();
+  Fortran::semantics::Scope::Kind kind = owner.kind();
+  // Test if this is a procedure scope that contains a subprogram scope that is
+  // not an interface.
+  if (kind == Fortran::semantics::Scope::Kind::Subprogram ||
+      kind == Fortran::semantics::Scope::Kind::MainProgram)
+    for (const Fortran::semantics::Scope &childScope : owner.children())
+      if (childScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
+        if (const Fortran::semantics::Symbol *childSym = childScope.symbol())
+          if (const auto *details =
+                  childSym->detailsIf<Fortran::semantics::SubprogramDetails>())
+            if (!details->isInterface())
+              return true;
+  return false;
+}
+
+/// In case it is safe to track the properties in variables outside a
+/// descriptor, create the variables to hold the mutable properties of the
+/// entity var. The variables are not initialized here.
+static fir::MutableProperties
+createMutableProperties(Fortran::lower::AbstractConverter &converter,
+                        mlir::Location loc,
+                        const Fortran::lower::pft::Variable &var,
+                        mlir::ValueRange nonDeferredParams) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  const Fortran::semantics::Symbol &sym = var.getSymbol();
+  // Globals and dummies may be associated, creating local variables would
+  // require keeping the values and descriptor before and after every single
+  // impure calls in the current scope (not only the ones taking the variable as
+  // arguments. All.) Volatile means the variable may change in ways not defined
+  // per Fortran, so lowering can most likely not keep the descriptor and values
+  // in sync as needed.
+  // Pointers to non contiguous arrays need to be represented with a fir.box to
+  // account for the discontiguity.
+  // Pointer/Allocatable in internal procedure are descriptors in the host link,
+  // and it would increase complexity to sync this descriptor with the local
+  // values every time the host link is escaping.
+  if (var.isGlobal() || Fortran::semantics::IsDummy(sym) ||
+      Fortran::semantics::IsFunctionResult(sym) ||
+      sym.attrs().test(Fortran::semantics::Attr::VOLATILE) ||
+      isNonContiguousArrayPointer(sym) || useAllocateRuntime ||
+      useDescForMutableBox || mayBeCapturedInInternalProc(sym))
+    return {};
+  fir::MutableProperties mutableProperties;
+  std::string name = converter.mangleName(sym);
+  mlir::Type baseAddrTy = converter.genType(sym);
+  if (auto boxType = baseAddrTy.dyn_cast<fir::BoxType>())
+    baseAddrTy = boxType.getEleTy();
+  // Allocate and set a variable to hold the address.
+  // It will be set to null in setUnallocatedStatus.
+  mutableProperties.addr =
+      builder.allocateLocal(loc, baseAddrTy, name + ".addr", "",
+                            /*shape=*/llvm::None, /*typeparams=*/llvm::None);
+  // Allocate variables to hold lower bounds and extents.
+  int rank = sym.Rank();
+  mlir::Type idxTy = builder.getIndexType();
+  for (decltype(rank) i = 0; i < rank; ++i) {
+    mlir::Value lboundVar =
+        builder.allocateLocal(loc, idxTy, name + ".lb" + std::to_string(i), "",
+                              /*shape=*/llvm::None, /*typeparams=*/llvm::None);
+    mlir::Value extentVar =
+        builder.allocateLocal(loc, idxTy, name + ".ext" + std::to_string(i), "",
+                              /*shape=*/llvm::None, /*typeparams=*/llvm::None);
+    mutableProperties.lbounds.emplace_back(lboundVar);
+    mutableProperties.extents.emplace_back(extentVar);
+  }
+
+  // Allocate variable to hold deferred length parameters.
+  mlir::Type eleTy = baseAddrTy;
+  if (auto newTy = fir::dyn_cast_ptrEleTy(eleTy))
+    eleTy = newTy;
+  if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
+    eleTy = seqTy.getEleTy();
+  if (auto record = eleTy.dyn_cast<fir::RecordType>())
+    if (record.getNumLenParams() != 0)
+      TODO(loc, "deferred length type parameters.");
+  if (fir::isa_char(eleTy) && nonDeferredParams.empty()) {
+    mlir::Value lenVar =
+        builder.allocateLocal(loc, builder.getCharacterLengthType(),
+                              name + ".len", "", /*shape=*/llvm::None,
+                              /*typeparams=*/llvm::None);
+    mutableProperties.deferredParams.emplace_back(lenVar);
+  }
+  return mutableProperties;
+}
+
+fir::MutableBoxValue Fortran::lower::createMutableBox(
+    Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+    const Fortran::lower::pft::Variable &var, mlir::Value boxAddr,
+    mlir::ValueRange nonDeferredParams) {
+
+  fir::MutableProperties mutableProperties =
+      createMutableProperties(converter, loc, var, nonDeferredParams);
+  fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))
+    fir::factory::disassociateMutableBox(builder, loc, box);
+  return box;
+}

flang/lib/Lower/Bridge.cpp

 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/PFTBuilder.h"
 #include "flang/Lower/Runtime.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/BoxValue.h"
+#include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Support/FIRContext.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
 #include "mlir/IR/PatternMatch.h"
 #include "mlir/Transforms/RegionUtils.h"
 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/Debug.h"
 
public:
   }
   fir::ExtendedValue
   genExprValue(const Fortran::lower::SomeExpr &expr,
                Fortran::lower::StatementContext &context,
                mlir::Location *loc = nullptr) override final {
     return createSomeExtendedExpression(loc ? *loc : toLocation(), *this, expr,
                                         localSymbols, context);
   }
+  fir::MutableBoxValue
+  genExprMutableBox(mlir::Location loc,
+                    const Fortran::lower::SomeExpr &expr) override final {
+    return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);
+  }
 
   Fortran::evaluate::FoldingContext &getFoldingContext() override final {
     return foldingContext;
   }
 
   mlir::Type genType(const Fortran::evaluate::DataRef &) override final {
     TODO_NOLOC("Not implemented genType DataRef. Needed for more complex "
                "expression lowering");
std::visit(
               }
 
               // Scalar assignment
               const bool isNumericScalar =
                   isNumericScalarCategory(lhsType->category());
               fir::ExtendedValue rhs = isNumericScalar
                                            ? genExprValue(assign.rhs, stmtCtx)
                                            : genExprAddr(assign.rhs, stmtCtx);
+              bool lhsIsWholeAllocatable = isWholeAllocatable(assign.lhs);
+              llvm::Optional<fir::factory::MutableBoxReallocation> lhsRealloc;
+              llvm::Optional<fir::MutableBoxValue> lhsMutableBox;
+              auto lhs = [&]() -> fir::ExtendedValue {
+                if (lhsIsWholeAllocatable) {
+                  lhsMutableBox = genExprMutableBox(loc, assign.lhs);
+                  llvm::SmallVector<mlir::Value> lengthParams;
+                  if (const fir::CharBoxValue *charBox = rhs.getCharBox())
+                    lengthParams.push_back(charBox->getLen());
+                  else if (fir::isDerivedWithLengthParameters(rhs))
+                    TODO(loc, "assignment to derived type allocatable with "
+                              "length parameters");
+                  lhsRealloc = fir::factory::genReallocIfNeeded(
+                      *builder, loc, *lhsMutableBox,
+                      /*shape=*/llvm::None, lengthParams);
+                  return lhsRealloc->newValue;
+                }
+                return genExprAddr(assign.lhs, stmtCtx);
+              }();
 
               if (isNumericScalar) {
                 // Fortran 2018 10.2.1.3 p8 and p9
                 // Conversions should have been inserted by semantic analysis,
                 // but they can be incorrect between the rhs and lhs. Correct
                 // that here.
-                mlir::Value addr =
-                    fir::getBase(genExprAddr(assign.lhs, stmtCtx));
+                mlir::Value addr = fir::getBase(lhs);
                 mlir::Value val = fir::getBase(rhs);
                 // A function with multiple entry points returning different
                 // types tags all result variables with one of the largest
                 // types to allow them to share the same storage.  Assignment
                 // to a result variable of one of the other types requires
                 // conversion to the actual type.
                 mlir::Type toTy = genType(assign.lhs);
                 mlir::Value cast =
                     builder->convertWithSemantics(loc, toTy, val);
                 if (fir::dyn_cast_ptrEleTy(addr.getType()) != toTy) {
                   assert(isFuncResultDesignator(assign.lhs) && "type mismatch");
                   addr = builder->createConvert(
                       toLocation(), builder->getRefType(toTy), addr);
                 }
                 builder->create<fir::StoreOp>(loc, cast, addr);
               } else if (isCharacterCategory(lhsType->category())) {
                 TODO(toLocation(), "Character assignment");
               } else if (isDerivedCategory(lhsType->category())) {
                 TODO(toLocation(), "Derived type assignment");
               } else {
                 llvm_unreachable("unknown category");
               }
+              if (lhsIsWholeAllocatable)
+                fir::factory::finalizeRealloc(
+                    *builder, loc, lhsMutableBox.getValue(),
+                    /*lbounds=*/llvm::None, /*takeLboundsIfRealloc=*/false,
+                    lhsRealloc.getValue());
             },
 
             // [2] User defined assignment. If the context is a scalar
             // expression then call the procedure.
             [&](const Fortran::evaluate::ProcedureRef &procRef) {
               TODO(toLocation(), "User defined assignment");
             },
 

flang/lib/Lower/CMakeLists.txt

 get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS)
 
 add_flang_library(FortranLower
+  Allocatable.cpp
   Bridge.cpp
   CallInterface.cpp
   Coarray.cpp
   ConvertExpr.cpp
   ConvertType.cpp
   ConvertVariable.cpp
   IntrinsicCall.cpp
   Mangler.cpp

flang/lib/Lower/ConvertExpr.cpp

ExtValue genBoxArg(const Fortran::lower::SomeExpr &expr) {
     useBoxArg = saveUseBoxArg;
     return result;
   }
 
   ExtValue genExtValue(const Fortran::lower::SomeExpr &expr) {
     return genval(expr);
   }
 
+  /// Lower an expression that is a pointer or an allocatable to a
+  /// MutableBoxValue.
+  fir::MutableBoxValue
+  genMutableBoxValue(const Fortran::lower::SomeExpr &expr) {
+    // Pointers and allocatables can only be:
+    //    - a simple designator "x"
+    //    - a component designator "a%b(i,j)%x"
+    //    - a function reference "foo()"
+    //    - result of NULL() or NULL(MOLD) intrinsic.
+    //    NULL() requires some context to be lowered, so it is not handled
+    //    here and must be lowered according to the context where it appears.
+    ExtValue exv = std::visit(
+        [&](const auto &x) { return genMutableBoxValueImpl(x); }, expr.u);
+    const fir::MutableBoxValue *mutableBox =
+        exv.getBoxOf<fir::MutableBoxValue>();
+    if (!mutableBox)
+      fir::emitFatalError(getLoc(), "expr was not lowered to MutableBoxValue");
+    return *mutableBox;
+  }
+
+  template <typename T>
+  ExtValue genMutableBoxValueImpl(const T &) {
+    // NULL() case should not be handled here.
+    fir::emitFatalError(getLoc(), "NULL() must be lowered in its context");
+  }
+
+  template <typename T>
+  ExtValue
+  genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef<T> &funRef) {
+    return genRawProcedureRef(funRef, converter.genType(toEvExpr(funRef)));
+  }
+
+  template <typename T>
+  ExtValue
+  genMutableBoxValueImpl(const Fortran::evaluate::Designator<T> &designator) {
+    return std::visit(
+        Fortran::common::visitors{
+            [&](const Fortran::evaluate::SymbolRef &sym) -> ExtValue {
+              return symMap.lookupSymbol(*sym).toExtendedValue();
+            },
+            [&](const Fortran::evaluate::Component &comp) -> ExtValue {
+              TODO(getLoc(), "genMutableBoxValueImpl Component");
+            },
+            [&](const auto &) -> ExtValue {
+              fir::emitFatalError(getLoc(),
+                                  "not an allocatable or pointer designator");
+            }},
+        designator.u);
+  }
+
+  template <typename T>
+  ExtValue genMutableBoxValueImpl(const Fortran::evaluate::Expr<T> &expr) {
+    return std::visit([&](const auto &x) { return genMutableBoxValueImpl(x); },
+                      expr.u);
+  }
+
   mlir::Location getLoc() { return location; }
 
   template <typename A>
   mlir::Value genunbox(const A &expr) {
     ExtValue e = genval(expr);
     if (const fir::UnboxedValue *r = e.getUnboxed())
       return *r;
     fir::emitFatalError(getLoc(), "unboxed expression expected");

 fir::ExtendedValue Fortran::lower::createSomeExtendedAddress(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
     Fortran::lower::StatementContext &stmtCtx) {
   LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "address: ") << '\n');
   return ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(expr);
 }
 
+fir::MutableBoxValue Fortran::lower::createMutableBox(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) {
+  // MutableBox lowering StatementContext does not need to be propagated
+  // to the caller because the result value is a variable, not a temporary
+  // expression. The StatementContext clean-up can occur before using the
+  // resulting MutableBoxValue. Variables of all other types are handled in the
+  // bridge.
+  Fortran::lower::StatementContext dummyStmtCtx;
+  return ScalarExprLowering{loc, converter, symMap, dummyStmtCtx}
+      .genMutableBoxValue(expr);
+}
+
 mlir::Value Fortran::lower::createSubroutineCall(
     AbstractConverter &converter, const evaluate::ProcedureRef &call,
     SymMap &symMap, StatementContext &stmtCtx) {
   mlir::Location loc = converter.getCurrentLocation();
 
   // Simple subroutine call, with potential alternate return.
   auto res = Fortran::lower::createSomeExtendedExpression(
       loc, converter, toEvExpr(call), symMap, stmtCtx);
   return fir::getBase(res);
 }

flang/lib/Lower/ConvertVariable.cpp

 //===-- ConvertVariable.cpp -- bridge to lower to MLIR --------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/AbstractConverter.h"
+#include "flang/Lower/Allocatable.h"
+#include "flang/Lower/BoxAnalyzer.h"
 #include "flang/Lower/CallInterface.h"
 #include "flang/Lower/ConvertExpr.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Support/Utils.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/Derived.h"
 #include "flang/Optimizer/Dialect/FIRAttr.h"
 #include "flang/Optimizer/Dialect/FIRDialect.h"
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Support/FIRContext.h"
 #include "flang/Optimizer/Support/FatalError.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/Debug.h"
 
 #define DEBUG_TYPE "flang-lower-variable"
 
+/// Helper to lower a scalar expression using a specific symbol mapping.
+static mlir::Value genScalarValue(Fortran::lower::AbstractConverter &converter,
+                                  mlir::Location loc,
+                                  const Fortran::lower::SomeExpr &expr,
+                                  Fortran::lower::SymMap &symMap,
+                                  Fortran::lower::StatementContext &context) {
+  // This does not use the AbstractConverter member function to override the
+  // symbol mapping to be used expression lowering.
+  return fir::getBase(Fortran::lower::createSomeExtendedExpression(
+      loc, converter, expr, symMap, context));
+}
+
 //===----------------------------------------------------------------===//
 // Local variables instantiation (not for alias)
 //===----------------------------------------------------------------===//
 
 /// Create a stack slot for a local variable. Precondition: the insertion
 /// point of the builder must be in the entry block, which is currently being
 /// constructed.
 static mlir::Value createNewLocal(Fortran::lower::AbstractConverter &converter,

 
 /// Instantiate a local variable. Precondition: Each variable will be visited
 /// such that if its properties depend on other variables, the variables upon
 /// which its properties depend will already have been visited.
 static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
                              const Fortran::lower::pft::Variable &var,
                              Fortran::lower::SymMap &symMap) {
   assert(!var.isAlias());
+  Fortran::lower::StatementContext stmtCtx;
+  mapSymbolAttributes(converter, var, symMap, stmtCtx);
+}
+
+/// Helper to decide if a dummy argument must be tracked in an BoxValue.
+static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym,
+                            mlir::Value dummyArg) {
+  // Only dummy arguments coming as fir.box can be tracked in an BoxValue.
+  if (!dummyArg || !dummyArg.getType().isa<fir::BoxType>())
+    return false;
+  // Non contiguous arrays must be tracked in an BoxValue.
+  if (sym.Rank() > 0 && !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS))
+    return true;
+  // Assumed rank and optional fir.box cannot yet be read while lowering the
+  // specifications.
+  if (Fortran::evaluate::IsAssumedRank(sym) ||
+      Fortran::semantics::IsOptional(sym))
+    return true;
+  // Polymorphic entity should be tracked through a fir.box that has the
+  // dynamic type info.
+  if (const Fortran::semantics::DeclTypeSpec *type = sym.GetType())
+    if (type->IsPolymorphic())
+      return true;
+  return false;
+}
+
+/// Compute extent from lower and upper bound.
+static mlir::Value computeExtent(fir::FirOpBuilder &builder, mlir::Location loc,
+                                 mlir::Value lb, mlir::Value ub) {
+  mlir::IndexType idxTy = builder.getIndexType();
+  // Let the folder deal with the common `ub - <const> + 1` case.
+  auto diff = builder.create<mlir::arith::SubIOp>(loc, idxTy, ub, lb);
+  mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+  return builder.create<mlir::arith::AddIOp>(loc, idxTy, diff, one);
+}
+
+/// Lower explicit lower bounds into \p result. Does nothing if this is not an
+/// array, or if the lower bounds are deferred, or all implicit or one.
+static void lowerExplicitLowerBounds(
+    Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+    const Fortran::lower::BoxAnalyzer &box,
+    llvm::SmallVectorImpl<mlir::Value> &result, Fortran::lower::SymMap &symMap,
+    Fortran::lower::StatementContext &stmtCtx) {
+  if (!box.isArray() || box.lboundIsAllOnes())
+    return;
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::IndexType idxTy = builder.getIndexType();
+  if (box.isStaticArray()) {
+    for (int64_t lb : box.staticLBound())
+      result.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
+    return;
+  }
+  for (const Fortran::semantics::ShapeSpec *spec : box.dynamicBound()) {
+    if (auto low = spec->lbound().GetExplicit()) {
+      auto expr = Fortran::lower::SomeExpr{*low};
+      mlir::Value lb = builder.createConvert(
+          loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx));
+      result.emplace_back(lb);
+    } else if (!spec->lbound().isColon()) {
+      // Implicit lower bound is 1 (Fortran 2018 section 8.5.8.3 point 3.)
+      result.emplace_back(builder.createIntegerConstant(loc, idxTy, 1));
+    }
+  }
+  assert(result.empty() || result.size() == box.dynamicBound().size());
+}
+
+/// Lower explicit extents into \p result if this is an explicit-shape or
+/// assumed-size array. Does nothing if this is not an explicit-shape or
+/// assumed-size array.
+static void lowerExplicitExtents(Fortran::lower::AbstractConverter &converter,
+                                 mlir::Location loc,
+                                 const Fortran::lower::BoxAnalyzer &box,
+                                 llvm::ArrayRef<mlir::Value> lowerBounds,
+                                 llvm::SmallVectorImpl<mlir::Value> &result,
+                                 Fortran::lower::SymMap &symMap,
+                                 Fortran::lower::StatementContext &stmtCtx) {
+  if (!box.isArray())
+    return;
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::IndexType idxTy = builder.getIndexType();
+  if (box.isStaticArray()) {
+    for (int64_t extent : box.staticShape())
+      result.emplace_back(builder.createIntegerConstant(loc, idxTy, extent));
+    return;
+  }
+  for (const auto &spec : llvm::enumerate(box.dynamicBound())) {
+    if (auto up = spec.value()->ubound().GetExplicit()) {
+      auto expr = Fortran::lower::SomeExpr{*up};
+      mlir::Value ub = builder.createConvert(
+          loc, idxTy, genScalarValue(converter, loc, expr, symMap, stmtCtx));
+      if (lowerBounds.empty())
+        result.emplace_back(ub);
+      else
+        result.emplace_back(
+            computeExtent(builder, loc, lowerBounds[spec.index()], ub));
+    } else if (spec.value()->ubound().isStar()) {
+      // Assumed extent is undefined. Must be provided by user's code.
+      result.emplace_back(builder.create<fir::UndefOp>(loc, idxTy));
+    }
+  }
+  assert(result.empty() || result.size() == box.dynamicBound().size());
+}
+
+/// Treat negative values as undefined. Assumed size arrays will return -1 from
+/// the front end for example. Using negative values can produce hard to find
+/// bugs much further along in the compilation.
+static mlir::Value genExtentValue(fir::FirOpBuilder &builder,
+                                  mlir::Location loc, mlir::Type idxTy,
+                                  long frontEndExtent) {
+  if (frontEndExtent >= 0)
+    return builder.createIntegerConstant(loc, idxTy, frontEndExtent);
+  return builder.create<fir::UndefOp>(loc, idxTy);
+}
+
+/// Lower specification expressions and attributes of variable \p var and
+/// add it to the symbol map.
+/// For global and aliases, the address must be pre-computed and provided
+/// in \p preAlloc.
+/// Dummy arguments must have already been mapped to mlir block arguments
+/// their mapping may be updated here.
+void Fortran::lower::mapSymbolAttributes(
+    AbstractConverter &converter, const Fortran::lower::pft::Variable &var,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
+    mlir::Value preAlloc) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   const Fortran::semantics::Symbol &sym = var.getSymbol();
+  const mlir::Location loc = converter.genLocation(sym.name());
+  mlir::IndexType idxTy = builder.getIndexType();
   const bool isDummy = Fortran::semantics::IsDummy(sym);
   const bool isResult = Fortran::semantics::IsFunctionResult(sym);
-  if (symMap.lookupSymbol(sym))
+  const bool replace = isDummy || isResult;
+  fir::factory::CharacterExprHelper charHelp{builder, loc};
+  Fortran::lower::BoxAnalyzer ba;
+  ba.analyze(sym);
+
+  // First deal with pointers an allocatables, because their handling here
+  // is the same regardless of their rank.
+  if (Fortran::semantics::IsAllocatableOrPointer(sym)) {
+    // Get address of fir.box describing the entity.
+    // global
+    mlir::Value boxAlloc = preAlloc;
+    // dummy or passed result
+    if (!boxAlloc)
+      if (Fortran::lower::SymbolBox symbox = symMap.lookupSymbol(sym))
+        boxAlloc = symbox.getAddr();
+    // local
+    if (!boxAlloc)
+      boxAlloc = createNewLocal(converter, loc, var, preAlloc);
+    // Lower non deferred parameters.
+    llvm::SmallVector<mlir::Value> nonDeferredLenParams;
+    if (ba.isChar()) {
+      TODO(loc, "mapSymbolAttributes allocatble or pointer char");
+    } else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) {
+      if (const Fortran::semantics::DerivedTypeSpec *derived =
+              declTy->AsDerived())
+        if (Fortran::semantics::CountLenParameters(*derived) != 0)
+          TODO(loc,
+               "derived type allocatable or pointer with length parameters");
+    }
+    fir::MutableBoxValue box = Fortran::lower::createMutableBox(
+        converter, loc, var, boxAlloc, nonDeferredLenParams);
+    symMap.addAllocatableOrPointer(var.getSymbol(), box, replace);
     return;
+  }
 
-  const mlir::Location loc = converter.genLocation(sym.name());
+  if (isDummy) {
+    mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr();
+    if (lowerToBoxValue(sym, dummyArg)) {
+      llvm::SmallVector<mlir::Value> lbounds;
+      llvm::SmallVector<mlir::Value> extents;
+      llvm::SmallVector<mlir::Value> explicitParams;
+      // Lower lower bounds, explicit type parameters and explicit
+      // extents if any.
+      if (ba.isChar())
+        TODO(loc, "lowerToBoxValue character");
+      // TODO: derived type length parameters.
+      lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx);
+      lowerExplicitExtents(converter, loc, ba, lbounds, extents, symMap,
+                           stmtCtx);
+      symMap.addBoxSymbol(sym, dummyArg, lbounds, explicitParams, extents,
+                          replace);
+      return;
+    }
+  }
+
+  // For symbols reaching this point, all properties are constant and can be
+  // read/computed already into ssa values.
+
+  ba.match(
+      //===--------------------------------------------------------------===//
+      // Trivial case.
+      //===--------------------------------------------------------------===//
+      [&](const Fortran::lower::details::ScalarSym &) {
         if (isDummy) {
           // This is an argument.
           if (!symMap.lookupSymbol(sym))
             mlir::emitError(loc, "symbol \"")
                 << toStringRef(sym.name()) << "\" must already be in map";
           return;
         } else if (isResult) {
           // Some Fortran results may be passed by argument (e.g. derived
           // types)
           if (symMap.lookupSymbol(sym))
             return;
         }
         // Otherwise, it's a local variable or function result.
-  mlir::Value local = createNewLocal(converter, loc, var, {});
+        mlir::Value local = createNewLocal(converter, loc, var, preAlloc);
         symMap.addSymbol(sym, local);
+      },
+
+      //===--------------------------------------------------------------===//
+      // The non-trivial cases are when we have an argument or local that has
+      // a repetition value. Arguments might be passed as simple pointers and
+      // need to be cast to a multi-dimensional array with constant bounds
+      // (possibly with a missing column), bounds computed in the callee
+      // (here), or with bounds from the caller (boxed somewhere else). Locals
+      // have the same properties except they are never boxed arguments from
+      // the caller and never having a missing column size.
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::details::ScalarStaticChar &x) {
+        TODO(loc, "mapSymbolAttributes ScalarStaticChar");
+      },
+
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::details::ScalarDynamicChar &x) {
+        TODO(loc, "mapSymbolAttributes ScalarDynamicChar");
+      },
+
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::details::StaticArray &x) {
+        // object shape is constant, not a character
+        mlir::Type castTy = builder.getRefType(converter.genType(var));
+        mlir::Value addr = symMap.lookupSymbol(sym).getAddr();
+        if (addr)
+          addr = builder.createConvert(loc, castTy, addr);
+        if (x.lboundAllOnes()) {
+          // if lower bounds are all ones, build simple shaped object
+          llvm::SmallVector<mlir::Value> shape;
+          for (int64_t i : x.shapes)
+            shape.push_back(genExtentValue(builder, loc, idxTy, i));
+          mlir::Value local =
+              isDummy ? addr : createNewLocal(converter, loc, var, preAlloc);
+          symMap.addSymbolWithShape(sym, local, shape, isDummy);
+          return;
+        }
+        // If object is an array process the lower bound and extent values by
+        // constructing constants and populating the lbounds and extents.
+        llvm::SmallVector<mlir::Value> extents;
+        llvm::SmallVector<mlir::Value> lbounds;
+        for (auto [fst, snd] : llvm::zip(x.lbounds, x.shapes)) {
+          lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, fst));
+          extents.emplace_back(genExtentValue(builder, loc, idxTy, snd));
+        }
+        mlir::Value local =
+            isDummy ? addr
+                    : createNewLocal(converter, loc, var, preAlloc, extents);
+        assert(isDummy || Fortran::lower::isExplicitShape(sym));
+        symMap.addSymbolWithBounds(sym, local, extents, lbounds, isDummy);
+      },
+
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::details::DynamicArray &x) {
+        TODO(loc, "mapSymbolAttributes DynamicArray");
+      },
+
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::details::StaticArrayStaticChar &x) {
+        TODO(loc, "mapSymbolAttributes StaticArrayStaticChar");
+      },
+
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::details::StaticArrayDynamicChar &x) {
+        TODO(loc, "mapSymbolAttributes StaticArrayDynamicChar");
+      },
+
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::details::DynamicArrayStaticChar &x) {
+        TODO(loc, "mapSymbolAttributes DynamicArrayStaticChar");
+      },
+
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::details::DynamicArrayDynamicChar &x) {
+        TODO(loc, "mapSymbolAttributes DynamicArrayDynamicChar");
+      },
+
+      //===--------------------------------------------------------------===//
+
+      [&](const Fortran::lower::BoxAnalyzer::None &) {
+        mlir::emitError(loc, "symbol analysis failed on ")
+            << toStringRef(sym.name());
+      });
 }
 
 void Fortran::lower::instantiateVariable(AbstractConverter &converter,
                                          const pft::Variable &var,
                                          SymMap &symMap) {
   const Fortran::semantics::Symbol &sym = var.getSymbol();
   const mlir::Location loc = converter.genLocation(sym.name());
   if (var.isAggregateStore()) {

flang/lib/Optimizer/Builder/MutableBox.cpp

 //===-- MutableBox.cpp -- MutableBox utilities ----------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Builder/Runtime/Derived.h"
+#include "flang/Optimizer/Builder/Runtime/Stop.h"
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Optimizer/Support/FatalError.h"
 
+/// Create a fir.box describing the new address, bounds, and length parameters
+/// for a MutableBox \p box.
+static mlir::Value createNewFirBox(fir::FirOpBuilder &builder,
+                                   mlir::Location loc,
+                                   const fir::MutableBoxValue &box,
+                                   mlir::Value addr, mlir::ValueRange lbounds,
+                                   mlir::ValueRange extents,
+                                   mlir::ValueRange lengths) {
+  if (addr.getType().isa<fir::BoxType>())
+    // The entity is already boxed.
+    return builder.createConvert(loc, box.getBoxTy(), addr);
+
+  mlir::Value shape;
+  if (!extents.empty()) {
+    if (lbounds.empty()) {
+      auto shapeType =
+          fir::ShapeType::get(builder.getContext(), extents.size());
+      shape = builder.create<fir::ShapeOp>(loc, shapeType, extents);
+    } else {
+      llvm::SmallVector<mlir::Value> shapeShiftBounds;
+      for (auto [lb, extent] : llvm::zip(lbounds, extents)) {
+        shapeShiftBounds.emplace_back(lb);
+        shapeShiftBounds.emplace_back(extent);
+      }
+      auto shapeShiftType =
+          fir::ShapeShiftType::get(builder.getContext(), extents.size());
+      shape = builder.create<fir::ShapeShiftOp>(loc, shapeShiftType,
+                                                shapeShiftBounds);
+    }
+  } // Otherwise, this a scalar. Leave the shape empty.
+
+  // Ignore lengths if already constant in the box type (this would trigger an
+  // error in the embox).
+  llvm::SmallVector<mlir::Value> cleanedLengths;
+  auto cleanedAddr = addr;
+  if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
+    // Cast address to box type so that both input and output type have
+    // unknown or constant lengths.
+    auto bt = box.getBaseTy();
+    auto addrTy = addr.getType();
+    auto type = addrTy.isa<fir::HeapType>()      ? fir::HeapType::get(bt)
+                : addrTy.isa<fir::PointerType>() ? fir::PointerType::get(bt)
+                                                 : builder.getRefType(bt);
+    cleanedAddr = builder.createConvert(loc, type, addr);
+    if (charTy.getLen() == fir::CharacterType::unknownLen())
+      cleanedLengths.append(lengths.begin(), lengths.end());
+  } else if (box.isDerivedWithLengthParameters()) {
+    TODO(loc, "updating mutablebox of derived type with length parameters");
+    cleanedLengths = lengths;
+  }
+  mlir::Value emptySlice;
+  return builder.create<fir::EmboxOp>(loc, box.getBoxTy(), cleanedAddr, shape,
+                                      emptySlice, cleanedLengths);
+}
+
 //===----------------------------------------------------------------------===//
 // MutableBoxValue writer and reader
 //===----------------------------------------------------------------------===//
 
 namespace {
 /// MutablePropertyWriter and MutablePropertyReader implementations are the only
 /// places that depend on how the properties of MutableBoxValue (pointers and
 /// allocatables) that can be modified in the lifetime of the entity (address,

 }
 
 void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder,
                                           mlir::Location loc,
                                           const fir::MutableBoxValue &box) {
   MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
 }
 
+static llvm::SmallVector<mlir::Value>
+getNewLengths(fir::FirOpBuilder &builder, mlir::Location loc,
+              const fir::MutableBoxValue &box, mlir::ValueRange lenParams) {
+  llvm::SmallVector<mlir::Value> lengths;
+  auto idxTy = builder.getIndexType();
+  if (auto charTy = box.getEleTy().dyn_cast<fir::CharacterType>()) {
+    if (charTy.getLen() == fir::CharacterType::unknownLen()) {
+      if (box.hasNonDeferredLenParams())
+        lengths.emplace_back(
+            builder.createConvert(loc, idxTy, box.nonDeferredLenParams()[0]));
+      else if (!lenParams.empty())
+        lengths.emplace_back(builder.createConvert(loc, idxTy, lenParams[0]));
+      else
+        fir::emitFatalError(
+            loc, "could not deduce character lengths in character allocation");
+    }
+  }
+  return lengths;
+}
+
+static mlir::Value allocateAndInitNewStorage(fir::FirOpBuilder &builder,
+                                             mlir::Location loc,
+                                             const fir::MutableBoxValue &box,
+                                             mlir::ValueRange extents,
+                                             mlir::ValueRange lenParams,
+                                             llvm::StringRef allocName) {
+  auto lengths = getNewLengths(builder, loc, box, lenParams);
+  auto newStorage = builder.create<fir::AllocMemOp>(
+      loc, box.getBaseTy(), allocName, lengths, extents);
+  if (box.getEleTy().isa<fir::RecordType>()) {
+    // TODO: skip runtime initialization if this is not required. Currently,
+    // there is no way to know here if a derived type needs it or not. But the
+    // information is available at compile time and could be reflected here
+    // somehow.
+    mlir::Value irBox = createNewFirBox(builder, loc, box, newStorage,
+                                        llvm::None, extents, lengths);
+    fir::runtime::genDerivedTypeInitialize(builder, loc, irBox);
+  }
+  return newStorage;
+}
+
 void fir::factory::genInlinedAllocation(fir::FirOpBuilder &builder,
                                         mlir::Location loc,
                                         const fir::MutableBoxValue &box,
                                         mlir::ValueRange lbounds,
                                         mlir::ValueRange extents,
                                         mlir::ValueRange lenParams,
                                         llvm::StringRef allocName) {
   auto idxTy = builder.getIndexType();

 void fir::factory::genInlinedDeallocate(fir::FirOpBuilder &builder,
                                         mlir::Location loc,
                                         const fir::MutableBoxValue &box) {
   auto addr = MutablePropertyReader(builder, loc, box).readBaseAddress();
   genFinalizeAndFree(builder, loc, addr);
   MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
 }
 
-void fir::factory::genReallocIfNeeded(fir::FirOpBuilder &builder,
-                                      mlir::Location loc,
-                                      const fir::MutableBoxValue &box,
-                                      mlir::ValueRange lbounds,
-                                      mlir::ValueRange shape,
-                                      mlir::ValueRange lengthParams) {
+fir::factory::MutableBoxReallocation
+fir::factory::genReallocIfNeeded(fir::FirOpBuilder &builder, mlir::Location loc,
   // Implement 10.2.1.3 point 3 logic when lhs is an array.
   auto reader = MutablePropertyReader(builder, loc, box);
   auto addr = reader.readBaseAddress();
+  auto i1Type = builder.getI1Type();
+  auto addrType = addr.getType();
   auto isAllocated = builder.genIsNotNull(loc, addr);
-  builder.genIfThenElse(loc, isAllocated)
+  auto ifOp =
+      builder
+          .genIfOp(loc, {i1Type, addrType}, isAllocated,
+                   /*withElseRegion=*/true)
           .genThen([&]() {
-        // The box is allocated. Check if it must be reallocated and reallocate.
-        mlir::Value mustReallocate = builder.createBool(loc, false);
-        auto compareProperty = [&](mlir::Value previous, mlir::Value required) {
+            // The box is allocated. Check if it must be reallocated and
+            // reallocate.
+            auto mustReallocate = builder.createBool(loc, false);
+            auto compareProperty = [&](mlir::Value previous,
+                                       mlir::Value required) {
               auto castPrevious =
                   builder.createConvert(loc, required.getType(), previous);
-          // reallocate = reallocate || previous != required
-          auto cmp = builder.create<arith::CmpIOp>(
-              loc, arith::CmpIPredicate::ne, castPrevious, required);
+              auto cmp = builder.create<mlir::arith::CmpIOp>(
+                  loc, mlir::arith::CmpIPredicate::ne, castPrevious, required);
               mustReallocate = builder.create<mlir::arith::SelectOp>(
                   loc, cmp, cmp, mustReallocate);
             };
-        llvm::SmallVector<mlir::Value> previousLbounds;
-        llvm::SmallVector<mlir::Value> previousExtents =
-            reader.readShape(&previousLbounds);
+            llvm::SmallVector<mlir::Value> previousExtents = reader.readShape();
             if (!shape.empty())
               for (auto [previousExtent, requested] :
                    llvm::zip(previousExtents, shape))
                 compareProperty(previousExtent, requested);
 
             if (box.isCharacter() && !box.hasNonDeferredLenParams()) {
               // When the allocatable length is not deferred, it must not be
-          // reallocated in case of length mismatch, instead, padding/trimming
-          // will ocur in later assignment to it.
+              // reallocated in case of length mismatch, instead,
+              // padding/trimming will occur in later assignment to it.
               assert(!lengthParams.empty() &&
                      "must provide length parameters for character");
               compareProperty(reader.readCharacterLength(), lengthParams[0]);
             } else if (box.isDerivedWithLengthParameters()) {
-          TODO(loc,
-               "automatic allocation of derived type allocatable with length "
-               "parameters");
+              TODO(loc, "automatic allocation of derived type allocatable with "
+                        "length parameters");
             }
-        builder.genIfThen(loc, mustReallocate)
+            auto ifOp =
+                builder
+                    .genIfOp(loc, {addrType}, mustReallocate,
+                             /*withElseRegion=*/true)
                     .genThen([&]() {
-              // If shape or length mismatch, deallocate and reallocate.
-              genFinalizeAndFree(builder, loc, addr);
+                      // If shape or length mismatch, allocate new storage.
                       // When rhs is a scalar, keep the previous shape
-              auto extents =
-                  shape.empty() ? mlir::ValueRange(previousExtents) : shape;
-              auto lbs =
-                  shape.empty() ? mlir::ValueRange(previousLbounds) : lbounds;
-              genInlinedAllocation(builder, loc, box, lbs, extents,
-                                   lengthParams, ".auto.alloc");
+                      auto extents = shape.empty()
+                                         ? mlir::ValueRange(previousExtents)
+                                         : shape;
+                      auto heap = allocateAndInitNewStorage(
+                          builder, loc, box, extents, lengthParams,
+                          ".auto.alloc");
+                      builder.create<fir::ResultOp>(loc, heap);
                     })
-            .end();
+                    .genElse(
+                        [&]() { builder.create<fir::ResultOp>(loc, addr); });
+            ifOp.end();
+            auto newAddr = ifOp.getResults()[0];
+            builder.create<fir::ResultOp>(
+                loc, mlir::ValueRange{mustReallocate, newAddr});
           })
           .genElse([&]() {
+            auto trueValue = builder.createBool(loc, true);
             // The box is not yet allocated, simply allocate it.
             if (shape.empty() && box.rank() != 0) {
-          // TODO:
-          // runtime error: right hand side must be allocated if right hand
-          // side is a scalar and the box is an array.
+              // See 10.2.1.3 p3.
+              fir::runtime::genReportFatalUserError(
+                  builder, loc,
+                  "array left hand side must be allocated when the right hand "
+                  "side is a scalar");
+              builder.create<fir::ResultOp>(loc,
+                                            mlir::ValueRange{trueValue, addr});
             } else {
-          genInlinedAllocation(builder, loc, box, lbounds, shape, lengthParams,
-                               ".auto.alloc");
+              auto heap = allocateAndInitNewStorage(
+                  builder, loc, box, shape, lengthParams, ".auto.alloc");
+              builder.create<fir::ResultOp>(loc,
+                                            mlir::ValueRange{trueValue, heap});
             }
+          });
+  ifOp.end();
+  auto wasReallocated = ifOp.getResults()[0];
+  auto newAddr = ifOp.getResults()[1];
+  // Create an ExtentedValue for the new storage.
+  auto newValue = [&]() -> fir::ExtendedValue {
+    mlir::SmallVector<mlir::Value> extents;
+    if (box.hasRank()) {
+      if (shape.empty())
+        extents = reader.readShape();
+      else
+        extents.append(shape.begin(), shape.end());
+    }
+    if (box.isCharacter()) {
+      auto len = box.hasNonDeferredLenParams() ? reader.readCharacterLength()
+                                               : lengthParams[0];
+      if (box.hasRank())
+        return fir::CharArrayBoxValue{newAddr, len, extents};
+      return fir::CharBoxValue{newAddr, len};
+    }
+    if (box.isDerivedWithLengthParameters())
+      TODO(loc, "reallocation of derived type entities with length parameters");
+    if (box.hasRank())
+      return fir::ArrayBoxValue{newAddr, extents};
+    return newAddr;
+  }();
+  return {newValue, addr, wasReallocated, isAllocated};
+}
+
+void fir::factory::finalizeRealloc(fir::FirOpBuilder &builder,
+                                   mlir::Location loc,
+                                   const fir::MutableBoxValue &box,
+                                   mlir::ValueRange lbounds,
+                                   bool takeLboundsIfRealloc,
+                                   const MutableBoxReallocation &realloc) {
+  builder.genIfThen(loc, realloc.wasReallocated)
+      .genThen([&]() {
+        auto reader = MutablePropertyReader(builder, loc, box);
+        llvm::SmallVector<mlir::Value> previousLbounds;
+        if (!takeLboundsIfRealloc && box.hasRank())
+          reader.readShape(&previousLbounds);
+        auto lbs =
+            takeLboundsIfRealloc ? lbounds : mlir::ValueRange{previousLbounds};
+        llvm::SmallVector<mlir::Value> lenParams;
+        if (box.isCharacter())
+          lenParams.push_back(fir::getLen(realloc.newValue));
+        if (box.isDerivedWithLengthParameters())
+          TODO(loc,
+               "reallocation of derived type entities with length parameters");
+        auto lengths = getNewLengths(builder, loc, box, lenParams);
+        auto heap = fir::getBase(realloc.newValue);
+        auto extents = fir::factory::getExtents(builder, loc, realloc.newValue);
+        builder.genIfThen(loc, realloc.oldAddressWasAllocated)
+            .genThen(
+                [&]() { genFinalizeAndFree(builder, loc, realloc.oldAddress); })
+            .end();
+        MutablePropertyWriter{builder, loc, box}.updateMutableBox(
+            heap, lbs, extents, lengths);
       })
       .end();
 }
 
 //===----------------------------------------------------------------------===//
 // MutableBoxValue syncing implementation
 //===----------------------------------------------------------------------===//
 

flang/lib/Optimizer/Builder/Runtime/Stop.cpp

 //===-- Stop.h - generate stop runtime API calls ----------------*- C++ -*-===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Optimizer/Builder/Runtime/Stop.h"
+#include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Runtime/stop.h"
 
 using namespace Fortran::runtime;
 
 void fir::runtime::genExit(fir::FirOpBuilder &builder, mlir::Location loc,
                            mlir::Value status) {
   auto exitFunc = fir::runtime::getRuntimeFunc<mkRTKey(Exit)>(loc, builder);
   llvm::SmallVector<mlir::Value> args =
       fir::runtime::createArguments(builder, loc, exitFunc.getType(), status);
   builder.create<fir::CallOp>(loc, exitFunc, args);
 }
+
+void fir::runtime::genReportFatalUserError(fir::FirOpBuilder &builder,
+                                           mlir::Location loc,
+                                           llvm::StringRef message) {
+  mlir::FuncOp crashFunc =
+      fir::runtime::getRuntimeFunc<mkRTKey(ReportFatalUserError)>(loc, builder);
+  mlir::FunctionType funcTy = crashFunc.getType();
+  mlir::Value msgVal = fir::getBase(
+      fir::factory::createStringLiteral(builder, loc, message.str() + '\0'));
+  mlir::Value sourceLine =
+      fir::factory::locationToLineNo(builder, loc, funcTy.getInput(2));
+  mlir::Value sourceFile = fir::factory::locationToFilename(builder, loc);
+  llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+      builder, loc, funcTy, msgVal, sourceFile, sourceLine);
+  builder.create<fir::CallOp>(loc, crashFunc, args);
+}

flang/test/Lower/allocatable-assignment.f90

+! Test allocatable assignments
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! -----------------------------------------------------------------------------
+!            Test simple scalar RHS
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPtest_simple_scalar(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<f32>>>{{.*}}) {
+subroutine test_simple_scalar(x)
+  real, allocatable  :: x
+! CHECK:  %[[VAL_1:.*]] = arith.constant 4.200000e+01 : f32
+! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<f32>>>
+! CHECK:  %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.heap<f32>>) -> !fir.heap<f32>
+! CHECK:  %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap<f32>) -> i64
+! CHECK:  %[[VAL_5:.*]] = arith.constant 0 : i64
+! CHECK:  %[[VAL_6:.*]] = arith.cmpi ne, %[[VAL_4]], %[[VAL_5]] : i64
+! CHECK:  %[[VAL_7:.*]]:2 = fir.if %[[VAL_6]] -> (i1, !fir.heap<f32>) {
+! CHECK:    %[[VAL_8:.*]] = arith.constant false
+! CHECK:    %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.heap<f32>) {
+! CHECK:      %[[VAL_10:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"}
+! CHECK:      fir.result %[[VAL_10]] : !fir.heap<f32>
+! CHECK:    } else {
+! CHECK:      fir.result %[[VAL_3]] : !fir.heap<f32>
+! CHECK:    }
+! CHECK:    fir.result %[[VAL_8]], %[[VAL_11:.*]] : i1, !fir.heap<f32>
+! CHECK:  } else {
+! CHECK:    %[[VAL_12:.*]] = arith.constant true
+! CHECK:    %[[VAL_13:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"}
+! CHECK:    fir.result %[[VAL_12]], %[[VAL_13]] : i1, !fir.heap<f32>
+! CHECK:  }
+! CHECK:  fir.store %[[VAL_1]] to %[[VAL_14:.*]]#1 : !fir.heap<f32>
+! CHECK:  fir.if %[[VAL_14]]#0 {
+! CHECK:    fir.if %[[VAL_6]] {
+! CHECK:      fir.freemem %[[VAL_3]]
+! CHECK:    }
+! CHECK:    %[[VAL_15:.*]] = fir.embox %[[VAL_14]]#1 : (!fir.heap<f32>) -> !fir.box<!fir.heap<f32>>
+! CHECK:    fir.store %[[VAL_15]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<f32>>>
+! CHECK:  }
+  x = 42.
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_simple_local_scalar() {
+subroutine test_simple_local_scalar()
+  real, allocatable  :: x
+! CHECK:  %[[VAL_1:.*]] = fir.alloca !fir.heap<f32> {uniq_name = "_QFtest_simple_local_scalarEx.addr"}
+! CHECK:  %[[VAL_2:.*]] = fir.zero_bits !fir.heap<f32>
+! CHECK:  fir.store %[[VAL_2]] to %[[VAL_1]] : !fir.ref<!fir.heap<f32>>
+! CHECK:  %[[VAL_3:.*]] = arith.constant 4.200000e+01 : f32
+! CHECK:  %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.heap<f32>>
+! CHECK:  %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.heap<f32>) -> i64
+! CHECK:  %[[VAL_6:.*]] = arith.constant 0 : i64
+! CHECK:  %[[VAL_7:.*]] = arith.cmpi ne, %[[VAL_5]], %[[VAL_6]] : i64
+! CHECK:  %[[VAL_8:.*]]:2 = fir.if %[[VAL_7]] -> (i1, !fir.heap<f32>) {
+! CHECK:    %[[VAL_9:.*]] = arith.constant false
+! CHECK:    %[[VAL_10:.*]] = fir.if %[[VAL_9]] -> (!fir.heap<f32>) {
+! CHECK:      %[[VAL_11:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"}
+! CHECK:      fir.result %[[VAL_11]] : !fir.heap<f32>
+! CHECK:    } else {
+! CHECK:      fir.result %[[VAL_4]] : !fir.heap<f32>
+! CHECK:    }
+! CHECK:    fir.result %[[VAL_9]], %[[VAL_12:.*]] : i1, !fir.heap<f32>
+! CHECK:  } else {
+! CHECK:    %[[VAL_13:.*]] = arith.constant true
+! CHECK:    %[[VAL_14:.*]] = fir.allocmem f32 {uniq_name = ".auto.alloc"}
+! CHECK:    fir.result %[[VAL_13]], %[[VAL_14]] : i1, !fir.heap<f32>
+! CHECK:  }
+! CHECK:  fir.store %[[VAL_3]] to %[[VAL_15:.*]]#1 : !fir.heap<f32>
+! CHECK:  fir.if %[[VAL_15]]#0 {
+! CHECK:    fir.if %[[VAL_7]] {
+! CHECK:      fir.freemem %[[VAL_4]]
+! CHECK:    }
+! CHECK:    fir.store %[[VAL_15]]#1 to %[[VAL_1]] : !fir.ref<!fir.heap<f32>>
+! CHECK:  }
+  x = 42.
+end subroutine