[flang] Lower boxed procedure

[clementval]

Summary

In FIR, we want to wrap function pointers in a special box known as a
boxproc value. Fortran has a limited form of dynamic scoping
[https://tinyurl.com/2p8v2hw7] between "host procedures" and "internal
procedures". There are a number of implementations possible.

Boxproc typed values abstract away the implementation details of when a
function pointer can be passed directly (as a raw address) and when a
function pointer has to account for the presence of a dynamic scope.
When lowering Fortran syntax to FIR, all function pointers are emboxed
as boxproc values.

When creating LLVM IR, we must strip away the abstraction and produce
low-level LLVM "assembly" code. This patch implements that
transformation as converting the boxproc values to either raw function
pointers or executable trampolines on the stack as needed. The
trampoline then captures the dynamic scope context within an executable
thunk that can be passed instead of the function's raw address.

Some extra handling is required for Fortran functions that return a
character value to deal with LEN values here.

Some of the code in Bridge.cpp and ConvertExpr.cpp and be re-arranged to
faciliate the upstreaming effort.

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

[jeanPerier]

flang/include/flang/Optimizer/Builder/FIRBuilder.h

63

I am not sure why the [[maybe_unused]] was added upstream, but this patch is not adding any usage to this function, so change looks odd to me.

451

Looks like upstream style fix is correct here.

454

en -> and ? (fir-dev likely misses the upstream fix)

[clementval]

Address review comment

flang/include/flang/Optimizer/Builder/FIRBuilder.h

63

Right. I'll put it back.

[jeanPerier]

LGTM

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Optimizer/Builder/FIRBuilder.h

63

I'm not sure about this particular usage, but I've run into bugs in some versions of GNU C++ where the compiler was incorrectly determining that a declaration was unused and emitting a warning that got turned into an error.

flang/include/flang/Lower/Bridge.h

 //===-- Lower/Bridge.h -- main interface to lowering ------------*- 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
 //
 //===----------------------------------------------------------------------===//
-///
-/// \file
-/// Implements lowering. Convert Fortran source to
-/// [MLIR](https://github.com/tensorflow/mlir).
-///
-/// [Coding style](https://llvm.org/docs/CodingStandards.html)
-///
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_LOWER_BRIDGE_H
 #define FORTRAN_LOWER_BRIDGE_H
 
 #include "flang/Common/Fortran.h"
 #include "flang/Lower/AbstractConverter.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
public:
   }
 
   /// Get the kind map.
   const fir::KindMapping &getKindMap() const { return kindMap; }
 
   /// Create a folding context. Careful: this is very expensive.
   Fortran::evaluate::FoldingContext createFoldingContext() const;
 
+  bool validModule() { return getModule(); }
+
   //===--------------------------------------------------------------------===//
   // Perform the creation of an mlir::ModuleOp
   //===--------------------------------------------------------------------===//
 
   /// Read in an MLIR input file rather than lowering Fortran sources.
   /// This is intended to be used for testing.
   void parseSourceFile(llvm::SourceMgr &);
 

flang/include/flang/Lower/CallInterface.h

 //===-- Lower/CallInterface.h -- Procedure call interface ------*- 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/
 //
 //===----------------------------------------------------------------------===//
 //
 // Utility that defines fir call interface for procedure both on caller and
 // and callee side and get the related FuncOp.
-// It does not emit any FIR code but for the created mlir::FuncOp, instead it
-// provides back a container of Symbol (callee side)/ActualArgument (caller
+// It does not emit any FIR code but for the created mlir::func::FuncOp, instead
+// it provides back a container of Symbol (callee side)/ActualArgument (caller
 // side) with additional information for each element describing how it must be
-// plugged with the mlir::FuncOp.
+// plugged with the mlir::func::FuncOp.
 // It handles the fact that hidden arguments may be inserted for the result.
 // while lowering.
 //
 // This utility uses the characteristic of Fortran procedures to operate, which
 // is a term and concept used in Fortran to refer to the signature of a function
 // or subroutine.
 //===----------------------------------------------------------------------===//
 
struct PassedEntityTypes<CalleeInterface> {
   using FirValue = mlir::Value;
 };
 
 /// Implementation helper
 template <typename T>
 class CallInterfaceImpl;
 
 /// CallInterface defines all the logic to determine FIR function interfaces
-/// from a characteristic, build the mlir::FuncOp and describe back the argument
-/// mapping to its user.
+/// from a characteristic, build the mlir::func::FuncOp and describe back the
+/// argument mapping to its user.
 /// The logic is shared between the callee and caller sides that it accepts as
 /// a curiously recursive template to handle the few things that cannot be
 /// shared between both sides (getting characteristics, mangled name, location).
 /// It maps FIR arguments to front-end Symbol (callee side) or ActualArgument
 /// (caller side) with the same code using the abstract FortranEntity type that
 /// can be either a Symbol or an ActualArgument.
 /// It works in two passes: a first pass over the characteristics that decides
 /// how the interface must be. Then, the funcOp is created for it. Then a simple
enum class Property {
     MutableBox,
     Value
   };
 
   using FortranEntity = typename PassedEntityTypes<T>::FortranEntity;
   using FirValue = typename PassedEntityTypes<T>::FirValue;
 
   /// FirPlaceHolder are place holders for the mlir inputs and outputs that are
-  /// created during the first pass before the mlir::FuncOp is created.
+  /// created during the first pass before the mlir::func::FuncOp is created.
   struct FirPlaceHolder {
     FirPlaceHolder(mlir::Type t, int passedPosition, Property p,
                    llvm::ArrayRef<mlir::NamedAttribute> attrs)
         : type{t}, passedEntityPosition{passedPosition}, property{p},
           attributes{attrs.begin(), attrs.end()} {}
     /// Type for this input/output
     mlir::Type type;
     /// Position of related passedEntity in passedArguments.
struct PassedEntity {
     bool isOptional() const;
     /// Can the argument be modified by the callee ?
     bool mayBeModifiedByCall() const;
     /// Can the argument be read by the callee ?
     bool mayBeReadByCall() const;
     /// How entity is passed by.
     PassEntityBy passBy;
     /// What is the entity (SymbolRef for callee/ActualArgument* for caller)
-    /// What is the related mlir::FuncOp argument(s) (mlir::Value for callee /
-    /// index for the caller).
+    /// What is the related mlir::func::FuncOp argument(s) (mlir::Value for
+    /// callee / index for the caller).
     FortranEntity entity;
     FirValue firArgument;
     FirValue firLength; /* only for AddressAndLength */
 
     /// Pointer to the argument characteristics. Nullptr for results.
     const Fortran::evaluate::characteristics::DummyArgument *characteristics =
         nullptr;
   };
 
-  /// Return the mlir::FuncOp. Note that front block is added by this
+  /// Return the mlir::func::FuncOp. Note that front block is added by this
   /// utility if callee side.
-  mlir::FuncOp getFuncOp() const { return func; }
+  mlir::func::FuncOp getFuncOp() const { return func; }
   /// Number of MLIR inputs/outputs of the created FuncOp.
   std::size_t getNumFIRArguments() const { return inputs.size(); }
   std::size_t getNumFIRResults() const { return outputs.size(); }
   /// Return the MLIR output types.
   llvm::SmallVector<mlir::Type> getResultType() const;
 
   /// Return a container of Symbol/ActualArgument* and how they must
-  /// be plugged with the mlir::FuncOp.
+  /// be plugged with the mlir::func::FuncOp.
   llvm::ArrayRef<PassedEntity> getPassedArguments() const {
     return passedArguments;
   }
   /// In case the result must be passed by the caller, indicate how.
   /// nullopt if the result is not passed by the caller.
   std::optional<PassedEntity> getPassedResult() const { return passedResult; }
   /// Returns the mlir function type
   mlir::FunctionType genFunctionType();
 
   /// determineInterface is the entry point of the first pass that defines the
-  /// interface and is required to get the mlir::FuncOp.
+  /// interface and is required to get the mlir::func::FuncOp.
   void
   determineInterface(bool isImplicit,
                      const Fortran::evaluate::characteristics::Procedure &);
 
   /// Does the caller need to allocate storage for the result ?
   bool callerAllocateResult() const {
     return mustPassResult() || mustSaveResult();
   }
 
   /// Is the Fortran result passed as an extra MLIR argument ?
   bool mustPassResult() const { return passedResult.has_value(); }
   /// Must the MLIR result be saved with a fir.save_result ?
   bool mustSaveResult() const { return saveResult; }
 
   /// Can the associated procedure be called via an implicit interface?
   bool canBeCalledViaImplicitInterface() const {
     return characteristic && characteristic->CanBeCalledViaImplicitInterface();
   }
 
 protected:
   CallInterface(Fortran::lower::AbstractConverter &c) : converter{c} {}
   /// CRTP handle.
   T &side() { return *static_cast<T *>(this); }
   /// Entry point to be called by child ctor to analyze the signature and
-  /// create/find the mlir::FuncOp. Child needs to be initialized first.
+  /// create/find the mlir::func::FuncOp. Child needs to be initialized first.
   void declare();
-  /// Second pass entry point, once the mlir::FuncOp is created.
+  /// Second pass entry point, once the mlir::func::FuncOp is created.
   /// Nothing is done if it was already called.
   void mapPassedEntities();
   void mapBackInputToPassedEntity(const FirPlaceHolder &, FirValue);
 
   llvm::SmallVector<FirPlaceHolder> outputs;
   llvm::SmallVector<FirPlaceHolder> inputs;
-  mlir::FuncOp func;
+  mlir::func::FuncOp func;
   llvm::SmallVector<PassedEntity> passedArguments;
   std::optional<PassedEntity> passedResult;
   bool saveResult = false;
 
   Fortran::lower::AbstractConverter &converter;
   /// Store characteristic once created, it is required for further information
   /// (e.g. getting the length of character result)
   std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =
public:
   std::string getMangledName() const;
   mlir::Location getCalleeLocation() const;
   Fortran::evaluate::characteristics::Procedure characterize() const;
 
   const Fortran::evaluate::ProcedureRef &getCallDescription() const {
     return procRef;
   }
 
+  /// Get the SubprogramDetails that defines the interface of this call if it is
+  /// known at the call site. Return nullptr if it is not known.
+  const Fortran::semantics::SubprogramDetails *getInterfaceDetails() const;
+
   bool isMainProgram() const { return false; }
 
   /// Returns true if this is a call to a procedure pointer of a dummy
   /// procedure.
   bool isIndirectCall() const;
 
   /// Return the procedure symbol if this is a call to a user defined
   /// procedure.
public:
   /// On the callee side it does not matter whether the procedure is
   /// called through pointers or not.
   bool isIndirectCall() const { return false; }
 
   /// Return the procedure symbol if this is a call to a user defined
   /// procedure.
   const Fortran::semantics::Symbol *getProcedureSymbol() const;
 
-  /// Add mlir::FuncOp entry block and map fir block arguments to Fortran dummy
-  /// argument symbols.
-  mlir::FuncOp addEntryBlockAndMapArguments();
+  /// Add mlir::func::FuncOp entry block and map fir block arguments to Fortran
+  /// dummy argument symbols.
+  mlir::func::FuncOp addEntryBlockAndMapArguments();
 
   bool hasHostAssociated() const;
   mlir::Type getHostAssociatedTy() const;
   mlir::Value getHostAssociatedTuple() const;
 
 private:
   Fortran::lower::pft::FunctionLikeUnit &funit;
 };
 
 /// Translate a procedure characteristics to an mlir::FunctionType signature.
 mlir::FunctionType
 translateSignature(const Fortran::evaluate::ProcedureDesignator &,
                    Fortran::lower::AbstractConverter &);
 
-/// Declare or find the mlir::FuncOp named \p name. If the mlir::FuncOp does
-/// not exist yet, declare it with the signature translated from the
-/// ProcedureDesignator argument.
+/// Declare or find the mlir::func::FuncOp named \p name. If the
+/// mlir::func::FuncOp does not exist yet, declare it with the signature
+/// translated from the ProcedureDesignator argument.
 /// Due to Fortran implicit function typing rules, the returned FuncOp is not
 /// guaranteed to have the signature from ProcedureDesignator if the FuncOp was
 /// already declared.
-mlir::FuncOp
+mlir::func::FuncOp
 getOrDeclareFunction(llvm::StringRef name,
                      const Fortran::evaluate::ProcedureDesignator &,
                      Fortran::lower::AbstractConverter &);
 
 /// Return the type of an argument that is a dummy procedure. This may be an
 /// mlir::FunctionType, but it can also be a more elaborate type based on the
 /// function type (like a tuple<function type, length type> for character
 /// functions).

flang/include/flang/Lower/ConvertExpr.h

 #define FORTRAN_LOWER_CONVERTEXPR_H
 
 #include "flang/Lower/Support/Utils.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 
 namespace mlir {
 class Location;
-}
+class Value;
+} // namespace mlir
 
-namespace Fortran::evaluate {
-template <typename>
-class Expr;
-struct SomeType;
-} // namespace Fortran::evaluate
+namespace fir {
+class AllocMemOp;
+class ArrayLoadOp;
+class ShapeOp;
+} // namespace fir
 
 namespace Fortran::lower {
 
 class AbstractConverter;
-class StatementContext;
-class SymMap;
 class ExplicitIterSpace;
 class ImplicitIterSpace;
 class StatementContext;
-
-using SomeExpr = Fortran::evaluate::Expr<Fortran::evaluate::SomeType>;
+class SymMap;
 
 /// Create an extended expression value.
 fir::ExtendedValue createSomeExtendedExpression(mlir::Location loc,
                                                 AbstractConverter &converter,
                                                 const SomeExpr &expr,
                                                 SymMap &symMap,
                                                 StatementContext &stmtCtx);
 
fir::ExtendedValue createInitializerAddress(mlir::Location loc,
                                             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 an array expression to a value of type box. The expression must be a
-/// variable.
-fir::ExtendedValue createSomeArrayBox(AbstractConverter &converter,
-                                      const SomeExpr &expr, SymMap &symMap,
-                                      StatementContext &stmtCtx);
-
-/// 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,
-                                 ExplicitIterSpace &explicitIterSpace,
-                                 ImplicitIterSpace &implicitIterSpace,
-                                 SymMap &symMap, StatementContext &stmtCtx,
-                                 bool isUserDefAssignment);
-
-/// 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);
-
 /// Create a fir::BoxValue describing the value of \p expr.
 /// If \p expr is a variable without vector subscripts, the fir::BoxValue
 /// described the variable storage. Otherwise, the created fir::BoxValue
 /// describes a temporary storage containing \p expr evaluation, and clean-up
 /// for the temporary is added to the provided StatementContext \p stmtCtx.
 fir::ExtendedValue createBoxValue(mlir::Location loc,
                                   AbstractConverter &converter,
                                   const SomeExpr &expr, SymMap &symMap,

 /// iteration space as well as a inner (subordinate) implied iteration
 /// space. The implied iteration space may include WHERE conditions, `masks`.
 void createAnyMaskedArrayAssignment(AbstractConverter &converter,
                                     const SomeExpr &lhs, const SomeExpr &rhs,
                                     ExplicitIterSpace &explicitIterSpace,
                                     ImplicitIterSpace &implicitIterSpace,
                                     SymMap &symMap, StatementContext &stmtCtx);
 
+/// In the context of a FORALL, a pointer assignment is allowed. The pointer
+/// assignment can be elementwise on an array of pointers. The bounds
+/// expressions as well as the component path may contain references to the
+/// concurrent control variables. The explicit iteration space must be defined.
+void createAnyArrayPointerAssignment(
+    AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs,
+    const evaluate::Assignment::BoundsSpec &bounds,
+    ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,
+    SymMap &symMap);
+/// Support the bounds remapping flavor of pointer assignment.
+void createAnyArrayPointerAssignment(
+    AbstractConverter &converter, const SomeExpr &lhs, const SomeExpr &rhs,
+    const evaluate::Assignment::BoundsRemapping &bounds,
+    ExplicitIterSpace &explicitIterSpace, ImplicitIterSpace &implicitIterSpace,
+    SymMap &symMap);
+
 /// Lower an assignment to an allocatable array, allocating the array if
 /// it is not allocated yet or reallocation it if it does not conform
 /// with the right hand side.
 void createAllocatableArrayAssignment(AbstractConverter &converter,
                                       const SomeExpr &lhs, const SomeExpr &rhs,
                                       ExplicitIterSpace &explicitIterSpace,
                                       ImplicitIterSpace &implicitIterSpace,
                                       SymMap &symMap,

 /// functions of other loop indices. The ragged array structure is built with \p
 /// raggedHeader being the root header variable. The header is a tuple of
 /// `{rank, data-is-headers, [data]*, [extents]*}`, which is built recursively.
 /// The base header, \p raggedHeader, must be initialized to zeros.
 void createLazyArrayTempValue(AbstractConverter &converter,
                               const SomeExpr &expr, mlir::Value raggedHeader,
                               SymMap &symMap, StatementContext &stmtCtx);
 
+/// Lower an array expression to a value of type box. The expression must be a
+/// variable.
+fir::ExtendedValue createSomeArrayBox(AbstractConverter &converter,
+                                      const SomeExpr &expr, SymMap &symMap,
+                                      StatementContext &stmtCtx);
+
+/// 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,
+                                 ExplicitIterSpace &explicitIterSpace,
+                                 ImplicitIterSpace &implicitIterSpace,
+                                 SymMap &symMap, StatementContext &stmtCtx,
+                                 bool isUserDefAssignment);
+
 // Attribute for an alloca that is a trivial adaptor for converting a value to
 // pass-by-ref semantics for a VALUE parameter. The optimizer may be able to
 // eliminate these.
 inline mlir::NamedAttribute getAdaptToByRefAttr(fir::FirOpBuilder &builder) {
   return {mlir::StringAttr::get(builder.getContext(),
                                 fir::getAdaptToByRefAttrName()),
           builder.getUnitAttr()};
 }
 
 /// Generate max(\p value, 0) where \p value is a scalar integer.
 mlir::Value genMaxWithZero(fir::FirOpBuilder &builder, mlir::Location loc,
                            mlir::Value value);
 
 } // namespace Fortran::lower
 
 #endif // FORTRAN_LOWER_CONVERTEXPR_H

flang/include/flang/Lower/IntrinsicCall.h

 // of intrinsic call lowering.
 //===----------------------------------------------------------------------===//
 
 /// Generate maximum. There must be at least one argument and all arguments
 /// must have the same type.
 mlir::Value genMax(fir::FirOpBuilder &, mlir::Location,
                    llvm::ArrayRef<mlir::Value> args);
 
+/// Generate minimum. Same constraints as genMax.
+mlir::Value genMin(fir::FirOpBuilder &, mlir::Location,
+                   llvm::ArrayRef<mlir::Value> args);
+
 /// Generate power function x**y with the given expected
 /// result type.
 mlir::Value genPow(fir::FirOpBuilder &, mlir::Location, mlir::Type resultType,
                    mlir::Value x, mlir::Value y);
 
 } // namespace Fortran::lower
 
 #endif // FORTRAN_LOWER_INTRINSICCALL_H

flang/include/flang/Optimizer/Builder/Character.h

 //===-- Character.h -- lowering of characters -------------------*- 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_OPTIMIZER_BUILDER_CHARACTER_H
 #define FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H
 
 #include "flang/Optimizer/Builder/BoxValue.h"
-#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
+
+namespace fir {
+class FirOpBuilder;
+}
 
 namespace fir::factory {
 
 /// Helper to facilitate lowering of CHARACTER in FIR.
 class CharacterExprHelper {
 public:
   /// Constructor.
-  explicit CharacterExprHelper(fir::FirOpBuilder &builder, mlir::Location loc)
+  explicit CharacterExprHelper(FirOpBuilder &builder, mlir::Location loc)
       : builder{builder}, loc{loc} {}
   CharacterExprHelper(const CharacterExprHelper &) = delete;
 
   /// Copy the \p count first characters of \p src into \p dest.
   /// \p count can have any integer type.
   void createCopy(const fir::CharBoxValue &dest, const fir::CharBoxValue &src,
                   mlir::Value count);
 
public:
   static bool hasConstantLengthInType(const fir::ExtendedValue &);
 
   /// Extract the kind of a character type
   static fir::KindTy getCharacterKind(mlir::Type type);
 
   /// Extract the kind of a character or array of character type.
   static fir::KindTy getCharacterOrSequenceKind(mlir::Type type);
 
+  // TODO: Do we really need all these flavors of unwrapping to get the fir.char
+  // type? Or can we merge these? It would be better to merge them and eliminate
+  // the confusion.
+
   /// Determine the inner character type. Unwraps references, boxes, and
   /// sequences to find the !fir.char element type.
   static fir::CharacterType getCharType(mlir::Type type);
 
-  /// Determine the base character type
+  /// Get fir.char<kind> type with the same kind as inside str.
   static fir::CharacterType getCharacterType(mlir::Type type);
   static fir::CharacterType getCharacterType(const fir::CharBoxValue &box);
   static fir::CharacterType getCharacterType(mlir::Value str);
 
   /// Create an extended value from a value of type:
   /// - fir.boxchar<kind>
   /// - fir.ref<fir.char<kind,len>>
   /// - fir.char<kind,len>
private:
   mlir::Value createElementAddr(mlir::Value buffer, mlir::Value index);
   mlir::Value createLoadCharAt(mlir::Value buff, mlir::Value index);
   void createStoreCharAt(mlir::Value str, mlir::Value index, mlir::Value c);
   void createLengthOneAssign(const fir::CharBoxValue &lhs,
                              const fir::CharBoxValue &rhs);
   void createAssign(const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs);
   mlir::Value createBlankConstantCode(fir::CharacterType type);
 
+private:
   FirOpBuilder &builder;
   mlir::Location loc;
 };
 
-// FIXME: Move these to Optimizer
-mlir::FuncOp getLlvmMemcpy(FirOpBuilder &builder);
-mlir::FuncOp getLlvmMemmove(FirOpBuilder &builder);
-mlir::FuncOp getLlvmMemset(FirOpBuilder &builder);
-mlir::FuncOp getRealloc(FirOpBuilder &builder);
-
 //===----------------------------------------------------------------------===//
 // Tools to work with Character dummy procedures
 //===----------------------------------------------------------------------===//
 
 /// Create a tuple<function type, length type> type to pass character functions
 /// as arguments along their length. The function type set in the tuple is the
 /// one provided by \p funcPointerType.
 mlir::Type getCharacterProcedureTupleType(mlir::Type funcPointerType);
 
-/// Is this tuple type holding a character function and its result length ?
-bool isCharacterProcedureTuple(mlir::Type type);
-
-/// Is \p tuple a value holding a character function address and its result
-/// length ?
-inline bool isCharacterProcedureTuple(mlir::Value tuple) {
-  return isCharacterProcedureTuple(tuple.getType());
-}
-
 /// Create a tuple<addr, len> given \p addr and \p len as well as the tuple
 /// type \p argTy. \p addr must be any function address, and \p len must be
 /// any integer. Converts will be inserted if needed if \addr and \p len
 /// types are not the same as the one inside the tuple type \p tupleType.
 mlir::Value createCharacterProcedureTuple(fir::FirOpBuilder &builder,
                                           mlir::Location loc,
                                           mlir::Type tupleType,
                                           mlir::Value addr, mlir::Value len);

flang/include/flang/Optimizer/Builder/FIRBuilder.h

 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H
 #define FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H
 
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Dialect/FIRType.h"
 #include "flang/Optimizer/Support/KindMapping.h"
-#include "mlir/Dialect/Func/IR/FuncOps.h"
 #include "mlir/IR/Builders.h"
 #include "mlir/IR/BuiltinOps.h"
+#include "llvm/ADT/DenseMap.h"
+#include "llvm/ADT/Optional.h"
 
 namespace fir {
 class AbstractArrayBox;
 class ExtendedValue;
 class BoxValue;
 
 //===----------------------------------------------------------------------===//
 // FirOpBuilder
public:
   mlir::FuncOp getFunction() {
     return getRegion().getParentOfType<mlir::FuncOp>();
   }
 
   /// Get a reference to the kind map.
   const fir::KindMapping &getKindMap() { return kindMap; }
 
   /// Get the default integer type
   [[maybe_unused]] mlir::IntegerType getDefaultIntegerType() {
     return getIntegerType(
         getKindMap().getIntegerBitsize(getKindMap().defaultIntegerKind()));
   }
 
   /// The LHS and RHS are not always in agreement in terms of type. In some
   /// cases, the disagreement is between COMPLEX and other scalar types. In that
   /// case, the conversion must insert (extract) out of a COMPLEX value to have
   /// the proper semantics and be strongly typed. E.g., converting an integer
mlir::Type getIntPtrType() {
     return getI64Type();
   }
 
   /// Wrap `str` to a SymbolRefAttr.
   mlir::SymbolRefAttr getSymbolRefAttr(llvm::StringRef str) {
     return mlir::SymbolRefAttr::get(getContext(), str);
   }
 
-  /// Get the mlir real type that implements fortran REAL(kind).
+  /// Get the mlir float type that implements Fortran REAL(kind).
   mlir::Type getRealType(int kind);
 
   fir::BoxProcType getBoxProcType(mlir::FunctionType funcTy) {
     return fir::BoxProcType::get(getContext(), funcTy);
   }
 
   /// Create a null constant memory reference of type \p ptrType.
   /// If \p ptrType is not provided, !fir.ref<none> type will be used.
public:
 
   mlir::StringAttr createWeakLinkage() { return getStringAttr("weak"); }
 
   /// Get a function by name. If the function exists in the current module, it
   /// is returned. Otherwise, a null FuncOp is returned.
   mlir::FuncOp getNamedFunction(llvm::StringRef name) {
     return getNamedFunction(getModule(), name);
   }
-
   static mlir::FuncOp getNamedFunction(mlir::ModuleOp module,
                                        llvm::StringRef name);
 
   /// Get a function by symbol name. The result will be null if there is no
   /// function with the given symbol in the module.
   mlir::FuncOp getNamedFunction(mlir::SymbolRefAttr symbol) {
     return getNamedFunction(getModule(), symbol);
   }
public:
   mlir::Value genIsNull(mlir::Location loc, mlir::Value addr);
 
   /// Compute the extent of (lb:ub:step) as max((ub-lb+step)/step, 0). See
   /// Fortran 2018 9.5.3.3.2 section for more details.
   mlir::Value genExtentFromTriplet(mlir::Location loc, mlir::Value lb,
                                    mlir::Value ub, mlir::Value step,
                                    mlir::Type type);
 
+  /// Dump the current function. (debug)
+  LLVM_DUMP_METHOD void dumpFunc();
+
 private:
   const KindMapping &kindMap;
 };
 
 } // namespace fir
 
 namespace fir::factory {
 

 /// Return length parameters associated to \p exv that are not deferred (that
 /// are available without having to read any fir.box values).
 /// Empty if \p exv has no length parameters or if they are all deferred.
 llvm::SmallVector<mlir::Value>
 getNonDeferredLengthParams(const fir::ExtendedValue &exv);
 
 //===----------------------------------------------------------------------===//
 // String literal helper helpers
 //===----------------------------------------------------------------------===//
 
 /// Create a !fir.char<1> string literal global and returns a
 /// fir::CharBoxValue with its address and length.
 fir::ExtendedValue createStringLiteral(fir::FirOpBuilder &, mlir::Location,
                                        llvm::StringRef string);
 
 /// Unique a compiler generated identifier. A short prefix should be provided
 /// to hint at the origin of the identifier.
 std::string uniqueCGIdent(llvm::StringRef prefix, llvm::StringRef name);
 
 /// Lowers the extents from the sequence type to Values.
 /// Any unknown extents are lowered to undefined values.
 llvm::SmallVector<mlir::Value> createExtents(fir::FirOpBuilder &builder,
                                              mlir::Location loc,
                                              fir::SequenceType seqTy);
 
-//===----------------------------------------------------------------------===//
+//===--------------------------------------------------------------------===//
 // Location helpers
-//===----------------------------------------------------------------------===//
+//===--------------------------------------------------------------------===//
 
 /// Generate a string literal containing the file name and return its address
 mlir::Value locationToFilename(fir::FirOpBuilder &, mlir::Location);
-
 /// Generate a constant of the given type with the location line number
 mlir::Value locationToLineNo(fir::FirOpBuilder &, mlir::Location, mlir::Type);
 
-/// Builds and returns the type of a ragged array header used to cache mask
-/// evaluations. RaggedArrayHeader is defined in
-/// flang/include/flang/Runtime/ragged.h.
-mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder);
-
-/// Create the zero value of a given the numerical or logical \p type (`false`
-/// for logical types).
-mlir::Value createZeroValue(fir::FirOpBuilder &builder, mlir::Location loc,
-                            mlir::Type type);
-
 //===--------------------------------------------------------------------===//
 // ExtendedValue helpers
 //===--------------------------------------------------------------------===//
 
 /// Return the extended value for a component of a derived type instance given
 /// the address of the component.
 fir::ExtendedValue componentToExtendedValue(fir::FirOpBuilder &builder,
                                             mlir::Location loc,
void genScalarAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
                          const fir::ExtendedValue &rhs);
 /// Assign \p rhs to \p lhs. Both \p rhs and \p lhs must be scalar derived
 /// types. The assignment follows Fortran intrinsic assignment semantic for
 /// derived types (10.2.1.3 point 13).
 void genRecordAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
                          const fir::ExtendedValue &lhs,
                          const fir::ExtendedValue &rhs);
 
+/// Builds and returns the type of a ragged array header used to cache mask
+/// evaluations. RaggedArrayHeader is defined in
+/// flang/include/flang/Runtime/ragged.h.
+mlir::TupleType getRaggedArrayHeaderType(fir::FirOpBuilder &builder);
+
 /// Generate the, possibly dynamic, LEN of a CHARACTER. \p arrLoad determines
 /// the base array. After applying \p path, the result must be a reference to a
 /// `!fir.char` type object. \p substring must have 0, 1, or 2 members. The
 /// first member is the starting offset. The second is the ending offset.
 mlir::Value genLenOfCharacter(fir::FirOpBuilder &builder, mlir::Location loc,
                               fir::ArrayLoadOp arrLoad,
                               llvm::ArrayRef<mlir::Value> path,
                               llvm::ArrayRef<mlir::Value> substring);
 mlir::Value genLenOfCharacter(fir::FirOpBuilder &builder, mlir::Location loc,
                               fir::SequenceType seqTy, mlir::Value memref,
                               llvm::ArrayRef<mlir::Value> typeParams,
                               llvm::ArrayRef<mlir::Value> path,
                               llvm::ArrayRef<mlir::Value> substring);
 
+/// Create the zero value of a given the numerical or logical \p type (`false`
+/// for logical types).
+mlir::Value createZeroValue(fir::FirOpBuilder &builder, mlir::Location loc,
+                            mlir::Type type);
+
 } // namespace fir::factory
 
 #endif // FORTRAN_OPTIMIZER_BUILDER_FIRBUILDER_H

flang/include/flang/Optimizer/Builder/LowLevelIntrinsics.h

 } // namespace func
 } // namespace mlir
 namespace fir {
 class FirOpBuilder;
 }
 
 namespace fir::factory {
 
+/// Get the LLVM intrinsic for `memcpy`. Use the 64 bit version.
+mlir::func::FuncOp getLlvmMemcpy(FirOpBuilder &builder);
+
+/// Get the LLVM intrinsic for `memmove`. Use the 64 bit version.
+mlir::func::FuncOp getLlvmMemmove(FirOpBuilder &builder);
+
+/// Get the LLVM intrinsic for `memset`. Use the 64 bit version.
+mlir::func::FuncOp getLlvmMemset(FirOpBuilder &builder);
+
+/// Get the C standard library `realloc` function.
+mlir::func::FuncOp getRealloc(FirOpBuilder &builder);
+
 /// Get the `llvm.stacksave` intrinsic.
 mlir::func::FuncOp getLlvmStackSave(FirOpBuilder &builder);
 
 /// Get the `llvm.stackrestore` intrinsic.
 mlir::func::FuncOp getLlvmStackRestore(FirOpBuilder &builder);
 
+/// Get the `llvm.init.trampoline` intrinsic.
+mlir::func::FuncOp getLlvmInitTrampoline(FirOpBuilder &builder);
+
+/// Get the `llvm.adjust.trampoline` intrinsic.
+mlir::func::FuncOp getLlvmAdjustTrampoline(FirOpBuilder &builder);
+
 } // namespace fir::factory
 
 #endif // FLANG_OPTIMIZER_BUILDER_LOWLEVELINTRINSICS_H

flang/include/flang/Optimizer/CodeGen/CGPasses.td

Option<"noCharacterConversion", "no-character-conversion",
            "bool", /*default=*/"false",
            "Disable target-specific conversion of CHARACTER.">,
     Option<"noComplexConversion", "no-complex-conversion",
            "bool", /*default=*/"false",
            "Disable target-specific conversion of COMPLEX.">
   ];
 }
 
+def BoxedProcedurePass : Pass<"boxed-procedure", "mlir::ModuleOp"> {
+  let constructor = "::fir::createBoxedProcedurePass()";
+  let options = [
+    Option<"useThunks", "use-thunks",
+           "bool", /*default=*/"true",
+           "Convert procedure pointer abstractions to a single code pointer, "
+           "deploying thunks wherever required.">
+  ];
+}
+
 #endif // FORTRAN_OPTIMIZER_CODEGEN_FIR_PASSES

flang/include/flang/Optimizer/CodeGen/CodeGen.h

 /// Convert FIR to the LLVM IR dialect with default options.
 std::unique_ptr<mlir::Pass> createFIRToLLVMPass();
 
 /// Convert FIR to the LLVM IR dialect
 std::unique_ptr<mlir::Pass> createFIRToLLVMPass(FIRToLLVMPassOptions options);
 
 using LLVMIRLoweringPrinter =
     std::function<void(llvm::Module &, llvm::raw_ostream &)>;
+
 /// Convert the LLVM IR dialect to LLVM-IR proper
 std::unique_ptr<mlir::Pass> createLLVMDialectToLLVMPass(
     llvm::raw_ostream &output,
     LLVMIRLoweringPrinter printer =
         [](llvm::Module &m, llvm::raw_ostream &out) { m.print(out, nullptr); });
 
+/// Convert boxproc values to a lower level representation. The default is to
+/// use function pointers and thunks.
+std::unique_ptr<mlir::Pass> createBoxedProcedurePass();
+std::unique_ptr<mlir::Pass> createBoxedProcedurePass(bool useThunks);
+
 // declarative passes
 #define GEN_PASS_REGISTRATION
 #include "flang/Optimizer/CodeGen/CGPasses.h.inc"
 
 } // namespace fir
 
 #endif // FORTRAN_OPTIMIZER_CODEGEN_CODEGEN_H

flang/include/flang/Optimizer/Dialect/FIROps.td

def fir_EmboxProcOp : fir_Op<"emboxproc", [NoSideEffect]> {
 
   let description = [{
     Creates an abstract encapsulation of a PROCEDURE POINTER along with an
     optional pointer to a host instance context. If the pointer is not to an
     internal procedure or the internal procedure does not need a host context
     then the form takes only the procedure's symbol.
 
     ```mlir
-      %0 = fir.emboxproc @f : ((i32) -> i32) -> !fir.boxproc<(i32) -> i32>
+      %f = ... : (i32) -> i32
+      %0 = fir.emboxproc %f : ((i32) -> i32) -> !fir.boxproc<(i32) -> i32>
     ```
 
     An internal procedure requiring a host instance for correct execution uses
     the second form. The closure of the host procedure's state is passed as a
     reference to a tuple. It is the responsibility of the host to manage the
     context's values accordingly, up to and including inhibiting register
     promotion of local values.
 
     ```mlir
-      %4 = ... : !fir.ref<tuple<i32, i32>>
-      %5 = fir.emboxproc @g, %4 : ((i32) -> i32, !fir.ref<tuple<i32, i32>>) -> !fir.boxproc<(i32) -> i32>
+      %4 = ... : !fir.ref<tuple<!fir.ref<i32>, !fir.ref<i32>>>
+      %g = ... : (i32) -> i32
+      %5 = fir.emboxproc %g, %4 : ((i32) -> i32, !fir.ref<tuple<!fir.ref<i32>, !fir.ref<i32>>>) -> !fir.boxproc<(i32) -> i32>
     ```
   }];
 
-  let arguments = (ins SymbolRefAttr:$funcname, AnyReferenceLike:$host);
+  let arguments = (ins FuncType:$func, Optional<fir_ReferenceType>:$host);
 
   let results = (outs fir_BoxProcType);
 
-  let hasCustomAssemblyFormat = 1;
+  let assemblyFormat = [{
+    $func (`,` $host^)? attr-dict `:` functional-type(operands, results)
+  }];
+
   let hasVerifier = 1;
 }
 
 def fir_UnboxCharOp : fir_SimpleOp<"unboxchar", [NoSideEffect]> {
   let summary = "unbox a boxchar value into a pair value";
 
   let description = [{
     Unboxes a value of `boxchar` type into a pair consisting of a memory
let description = [{
     This operator is overloaded to work with values of type `box`,
     `boxchar`, and `boxproc`.  The result for each of these
     cases, respectively, is the address of the data, the address of the
     `CHARACTER` data, and the address of the procedure.
 
     ```mlir
       %51 = fir.box_addr %box : (!fir.box<f64>) -> !fir.ref<f64>
       %52 = fir.box_addr %boxchar : (!fir.boxchar<1>) -> !fir.ref<!fir.char<1>>
-      %53 = fir.box_addr %boxproc : (!fir.boxproc<!P>) -> !fir.ref<!P>
+      %53 = fir.box_addr %boxproc : (!fir.boxproc<!P>) -> !P
     ```
   }];
 
-  let arguments = (ins fir_BoxType:$val);
+  let arguments = (ins AnyBoxLike:$val);
 
-  let results = (outs AnyReferenceLike);
+  let results = (outs AnyCodeOrDataRefLike);
 
   let hasFolder = 1;
 }
 
 def fir_BoxCharLenOp : fir_SimpleOp<"boxchar_len", [NoSideEffect]> {
   let summary = "return the LEN type parameter from a boxchar value";
 
   let description = [{

flang/include/flang/Optimizer/Dialect/FIROpsSupport.h

 #define FORTRAN_OPTIMIZER_DIALECT_FIROPSSUPPORT_H
 
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "mlir/Dialect/Func/IR/FuncOps.h"
 #include "mlir/IR/BuiltinOps.h"
 
 namespace fir {
 
-/// return true iff the Operation is a non-volatile LoadOp
+/// Return true iff the Operation is a non-volatile LoadOp or ArrayLoadOp.
 inline bool nonVolatileLoad(mlir::Operation *op) {
   if (auto load = mlir::dyn_cast<fir::LoadOp>(op))
     return !load->getAttr("volatile");
+  if (auto arrLoad = mlir::dyn_cast<fir::ArrayLoadOp>(op))
+    return !arrLoad->getAttr("volatile");
   return false;
 }
 
-/// return true iff the Operation is a call
+/// Return true iff the Operation is a call.
 inline bool isaCall(mlir::Operation *op) {
-  return mlir::isa<fir::CallOp>(op) || llvm::isa<fir::DispatchOp>(op) ||
+  return mlir::isa<fir::CallOp>(op) || mlir::isa<fir::DispatchOp>(op) ||
          mlir::isa<mlir::func::CallOp>(op) ||
          mlir::isa<mlir::func::CallIndirectOp>(op);
 }
 
 /// return true iff the Operation is a fir::CallOp, fir::DispatchOp,
 /// mlir::CallOp, or mlir::CallIndirectOp and not pure
 /// NB: this is not the same as `!pureCall(op)`
 inline bool impureCall(mlir::Operation *op) {

flang/include/flang/Optimizer/Dialect/FIRType.h

 /// conformsWithPassByRef(), which includes pointers and allocatables.
 inline bool isa_passbyref_type(mlir::Type t) {
   return t.isa<ReferenceType>() || isa_box_type(t) ||
          t.isa<mlir::FunctionType>();
 }
 
 /// Is `t` a type that can conform to be pass-by-reference? Depending on the
 /// context, these types may simply demote to pass-by-reference or a reference
-/// to them may have to be passed instead.
+/// to them may have to be passed instead. Functions are always referent.
 inline bool conformsWithPassByRef(mlir::Type t) {
-  return isa_ref_type(t) || isa_box_type(t);
+  return isa_ref_type(t) || isa_box_type(t) || t.isa<mlir::FunctionType>();
 }
 
 /// Is `t` a derived (record) type?
 inline bool isa_derived(mlir::Type t) { return t.isa<fir::RecordType>(); }
 
 /// Is `t` a FIR dialect aggregate type?
 inline bool isa_aggregate(mlir::Type t) {
   return t.isa<SequenceType>() || fir::isa_derived(t) ||

 /// (where rank > 0).
 inline bool sequenceWithNonConstantShape(fir::SequenceType seqTy) {
   return seqTy.hasUnknownShape() || !seqTy.hasConstantShape();
 }
 
 /// Returns true iff the type `t` does not have a constant size.
 bool hasDynamicSize(mlir::Type t);
 
+inline unsigned getRankOfShapeType(mlir::Type t) {
+  if (auto shTy = t.dyn_cast<fir::ShapeType>())
+    return shTy.getRank();
+  if (auto shTy = t.dyn_cast<fir::ShapeShiftType>())
+    return shTy.getRank();
+  if (auto shTy = t.dyn_cast<fir::ShiftType>())
+    return shTy.getRank();
+  return 0;
+}
+
 /// If `t` is a SequenceType return its element type, otherwise return `t`.
 inline mlir::Type unwrapSequenceType(mlir::Type t) {
   if (auto seqTy = t.dyn_cast<fir::SequenceType>())
     return seqTy.getEleTy();
   return t;
 }
 
 inline mlir::Type unwrapRefType(mlir::Type t) {
   if (auto eleTy = dyn_cast_ptrEleTy(t))
     return eleTy;
   return t;
 }
 
 /// If `t` conforms with a pass-by-reference type (box, ref, ptr, etc.) then
 /// return the element type of `t`. Otherwise, return `t`.
 inline mlir::Type unwrapPassByRefType(mlir::Type t) {
   if (auto eleTy = dyn_cast_ptrOrBoxEleTy(t))
     return eleTy;
   return t;
 }
 
+/// Unwrap all pointer and box types and return the element type if it is a
+/// sequence type, otherwise return null.
+inline fir::SequenceType unwrapUntilSeqType(mlir::Type t) {
+  while (true) {
+    if (!t)
+      return {};
+    if (auto ty = dyn_cast_ptrOrBoxEleTy(t)) {
+      t = ty;
+      continue;
+    }
+    if (auto seqTy = t.dyn_cast<fir::SequenceType>())
+      return seqTy;
+    return {};
+  }
+}
+
 #ifndef NDEBUG
 // !fir.ptr<X> and !fir.heap<X> where X is !fir.ptr, !fir.heap, or !fir.ref
 // is undefined and disallowed.
 inline bool singleIndirectionLevel(mlir::Type ty) {
   return !fir::isa_ref_type(ty);
 }
 #endif
 

flang/include/flang/Optimizer/Dialect/FIRTypes.td

def AnyCompositeLike : TypeConstraint<Or<[fir_RecordType.predicate,
     fir_VectorType.predicate, IsTupleTypePred, fir_CharacterType.predicate]>,
     "any composite">;
 
 // Reference types
 def AnyReferenceLike : TypeConstraint<Or<[fir_ReferenceType.predicate,
     fir_HeapType.predicate, fir_PointerType.predicate,
     fir_LLVMPointerType.predicate]>, "any reference">;
 
+def FuncType : TypeConstraint<FunctionType.predicate, "function type">;
+
+def AnyCodeOrDataRefLike : TypeConstraint<Or<[AnyReferenceLike.predicate,
+    FunctionType.predicate]>, "any code or data reference">;
+
 def RefOrLLVMPtr : TypeConstraint<Or<[fir_ReferenceType.predicate,
     fir_LLVMPointerType.predicate]>, "fir.ref or fir.llvm_ptr">;
 
 def AnyBoxLike : TypeConstraint<Or<[fir_BoxType.predicate,
     fir_BoxCharType.predicate, fir_BoxProcType.predicate]>, "any box">;
 
 def AnyRefOrBoxLike : TypeConstraint<Or<[AnyReferenceLike.predicate,
     AnyBoxLike.predicate]>,

flang/include/flang/Tools/CLOptions.inc

DisableOption(
     FirMao, "memory-allocation-opt", "memory allocation optimization");
 
 /// CodeGen Passes
 #if !defined(FLANG_EXCLUDE_CODEGEN)
 DisableOption(CodeGenRewrite, "codegen-rewrite", "rewrite FIR for codegen");
 DisableOption(TargetRewrite, "target-rewrite", "rewrite FIR for target");
 DisableOption(FirToLlvmIr, "fir-to-llvmir", "FIR to LLVM-IR dialect");
 DisableOption(LlvmIrToLlvm, "llvm", "conversion to LLVM");
+DisableOption(BoxedProcedureRewrite, "boxed-procedure-rewrite",
+    "rewrite boxed procedures");
 #endif
 
 /// Generic for adding a pass to the pass manager if it is not disabled.
 template <typename F>
 void addPassConditionally(
     mlir::PassManager &pm, llvm::cl::opt<bool> &disabled, F ctor) {
   if (!disabled)
     pm.addPass(ctor());
addPassConditionally(pm, disableFirToLlvmIr,
       [&]() { return fir::createFIRToLLVMPass(options); });
 }
 
 inline void addLLVMDialectToLLVMPass(
     mlir::PassManager &pm, llvm::raw_ostream &output) {
   addPassConditionally(pm, disableLlvmIrToLlvm,
       [&]() { return fir::createLLVMDialectToLLVMPass(output); });
 }
+
+inline void addBoxedProcedurePass(mlir::PassManager &pm) {
+  addPassConditionally(pm, disableBoxedProcedureRewrite,
+      [&]() { return fir::createBoxedProcedurePass(); });
+}
 #endif
 
 /// Create a pass pipeline for running default optimization passes for
 /// incremental conversion of FIR.
 ///
 /// \param pm - MLIR pass manager that will hold the pipeline definition
 inline void createDefaultFIROptimizerPassPipeline(mlir::PassManager &pm) {
   // simplify the IR
inline void createDefaultFIROptimizerPassPipeline(mlir::PassManager &pm) {
   pm.addPass(mlir::createConvertSCFToCFPass());
 
   pm.addPass(mlir::createCanonicalizerPass(config));
   pm.addPass(fir::createSimplifyRegionLitePass());
 }
 
 #if !defined(FLANG_EXCLUDE_CODEGEN)
 inline void createDefaultFIRCodeGenPassPipeline(mlir::PassManager &pm) {
+  fir::addBoxedProcedurePass(pm);
   pm.addNestedPass<mlir::FuncOp>(fir::createAbstractResultOptPass());
   fir::addCodeGenRewritePass(pm);
   fir::addTargetRewritePass(pm);
   fir::addFIRToLLVMPass(pm);
 }
 
 /// Create a pass pipeline for lowering from MLIR to LLVM IR
 ///

flang/lib/Lower/Bridge.cpp

 //===-- Bridge.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/Bridge.h"
-#include "flang/Evaluate/tools.h"
 #include "flang/Lower/Allocatable.h"
 #include "flang/Lower/CallInterface.h"
+#include "flang/Lower/Coarray.h"
 #include "flang/Lower/ConvertExpr.h"
 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
+#include "flang/Lower/HostAssociations.h"
 #include "flang/Lower/IO.h"
 #include "flang/Lower/IterationSpace.h"
 #include "flang/Lower/Mangler.h"
+#include "flang/Lower/OpenACC.h"
 #include "flang/Lower/OpenMP.h"
 #include "flang/Lower/PFTBuilder.h"
 #include "flang/Lower/Runtime.h"
 #include "flang/Lower/StatementContext.h"
-#include "flang/Lower/SymbolMap.h"
+#include "flang/Lower/Support/Utils.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/Character.h"
-#include "flang/Optimizer/Builder/MutableBox.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/Character.h"
 #include "flang/Optimizer/Builder/Runtime/Ragged.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/Optimizer/Support/InternalNames.h"
+#include "flang/Optimizer/Transforms/Passes.h"
+#include "flang/Parser/parse-tree.h"
 #include "flang/Runtime/iostat.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
 #include "mlir/IR/PatternMatch.h"
+#include "mlir/Parser/Parser.h"
 #include "mlir/Transforms/RegionUtils.h"
 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/Debug.h"
+#include "llvm/Support/ErrorHandling.h"
 
 #define DEBUG_TYPE "flang-lower-bridge"
 
-using namespace mlir;
-
 static llvm::cl::opt<bool> dumpBeforeFir(
     "fdebug-dump-pre-fir", llvm::cl::init(false),
     llvm::cl::desc("dump the Pre-FIR tree prior to FIR generation"));
 
+static llvm::cl::opt<bool> forceLoopToExecuteOnce(
+    "always-execute-loop-body", llvm::cl::init(false),
+    llvm::cl::desc("force the body of a loop to execute at least once"));
+
 namespace {
 /// Helper class to generate the runtime type info global data. This data
 /// is required to describe the derived type to the runtime so that it can
 /// operate over it. It must be ensured this data will be generated for every
 /// derived type lowered in the current translated unit. However, this data
 /// cannot be generated before FuncOp have been created for functions since the
 /// initializers may take their address (e.g for type bound procedures). This
 /// class allows registering all the required runtime type info while it is not
private:
   /// Create derived type runtime info global immediately without storing the
   /// symbol in registeredTypeInfoSymbols.
   bool skipRegistration = false;
   /// Track symbols symbols processed during and after the registration
   /// to avoid infinite loops between type conversions and global variable
   /// creation.
   llvm::SmallSetVector<Fortran::semantics::SymbolRef, 64> seen;
 };
+
 } // namespace
 
 //===----------------------------------------------------------------------===//
 // FirConverter
 //===----------------------------------------------------------------------===//
 
 namespace {
 
void run(Fortran::lower::pft::Program &pft) {
 
     // Primary translation pass.
     for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
       std::visit(
           Fortran::common::visitors{
               [&](Fortran::lower::pft::FunctionLikeUnit &f) { lowerFunc(f); },
               [&](Fortran::lower::pft::ModuleLikeUnit &m) { lowerMod(m); },
               [&](Fortran::lower::pft::BlockDataUnit &b) {},
-              [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
+              [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {
+                setCurrentPosition(
+                    d.get<Fortran::parser::CompilerDirective>().source);
+                mlir::emitWarning(toLocation(),
+                                  "ignoring all compiler directives");
+              },
           },
           u);
     }
 
     /// Once all the code has been translated, create runtime type info
     /// global data structure for the derived types that have been
     /// processed.
     createGlobalOutsideOfFunctionLowering(
lookupLabel(Fortran::lower::pft::Label label) override final {
     if (iter == owningProc.labelEvaluationMap.end())
       return nullptr;
     return iter->second;
   }
 
   fir::ExtendedValue genExprAddr(const Fortran::lower::SomeExpr &expr,
                                  Fortran::lower::StatementContext &context,
                                  mlir::Location *loc = nullptr) override final {
-    return createSomeExtendedAddress(loc ? *loc : toLocation(), *this, expr,
-                                     localSymbols, context);
+    return Fortran::lower::createSomeExtendedAddress(
+        loc ? *loc : toLocation(), *this, expr, localSymbols, context);
   }
   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);
+    return Fortran::lower::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);
   }
   fir::ExtendedValue genExprBox(const Fortran::lower::SomeExpr &expr,
                                 Fortran::lower::StatementContext &context,
                                 mlir::Location loc) override final {
     return Fortran::lower::createBoxValue(loc, *this, expr, localSymbols,
                                           context);
   }
 
   Fortran::evaluate::FoldingContext &getFoldingContext() override final {
     return foldingContext;
   }
 
   mlir::Type genType(const Fortran::lower::SomeExpr &expr) override final {
     return Fortran::lower::translateSomeExprToFIRType(*this, expr);
   }
+  mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {
+    return Fortran::lower::translateVariableToFIRType(*this, var);
+  }
   mlir::Type genType(Fortran::lower::SymbolRef sym) override final {
     return Fortran::lower::translateSymbolToFIRType(*this, sym);
   }
   mlir::Type
   genType(Fortran::common::TypeCategory tc, int kind,
           llvm::ArrayRef<std::int64_t> lenParameters) override final {
     return Fortran::lower::getFIRType(&getMLIRContext(), tc, kind,
                                       lenParameters);
   }
   mlir::Type
   genType(const Fortran::semantics::DerivedTypeSpec &tySpec) override final {
     return Fortran::lower::translateDerivedTypeToFIRType(*this, tySpec);
   }
   mlir::Type genType(Fortran::common::TypeCategory tc) override final {
-    TODO_NOLOC("Not implemented genType TypeCategory. Needed for more complex "
-               "expression lowering");
-  }
-  mlir::Type genType(const Fortran::lower::pft::Variable &var) override final {
-    return Fortran::lower::translateVariableToFIRType(*this, var);
-  }
-
-  void setCurrentPosition(const Fortran::parser::CharBlock &position) {
-    if (position != Fortran::parser::CharBlock{})
-      currentPosition = position;
-  }
-
-  //===--------------------------------------------------------------------===//
-  // Utility methods
-  //===--------------------------------------------------------------------===//
-
-  /// Convert a parser CharBlock to a Location
-  mlir::Location toLocation(const Fortran::parser::CharBlock &cb) {
-    return genLocation(cb);
-  }
-
-  mlir::Location toLocation() { return toLocation(currentPosition); }
-  void setCurrentEval(Fortran::lower::pft::Evaluation &eval) {
-    evalPtr = &eval;
-  }
-  Fortran::lower::pft::Evaluation &getEval() {
-    assert(evalPtr && "current evaluation not set");
-    return *evalPtr;
+    return Fortran::lower::getFIRType(
+        &getMLIRContext(), tc, bridge.getDefaultKinds().GetDefaultKind(tc),
+        llvm::None);
   }
 
   mlir::Location getCurrentLocation() override final { return toLocation(); }
 
   /// Generate a dummy location.
   mlir::Location genUnknownLocation() override final {
     // Note: builder may not be instantiated yet
     return mlir::UnknownLoc::get(&getMLIRContext());
public:
   mangleName(const Fortran::semantics::Symbol &symbol) override final {
     return Fortran::lower::mangle::mangleName(symbol);
   }
 
   const fir::KindMapping &getKindMap() override final {
     return bridge.getKindMap();
   }
 
-  /// Return the predicate: "current block does not have a terminator branch".
-  bool blockIsUnterminated() {
-    mlir::Block *currentBlock = builder->getBlock();
-    return currentBlock->empty() ||
-           !currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>();
-  }
-
-  /// Unconditionally switch code insertion to a new block.
-  void startBlock(mlir::Block *newBlock) {
-    assert(newBlock && "missing block");
-    // Default termination for the current block is a fallthrough branch to
-    // the new block.
-    if (blockIsUnterminated())
-      genFIRBranch(newBlock);
-    // Some blocks may be re/started more than once, and might not be empty.
-    // If the new block already has (only) a terminator, set the insertion
-    // point to the start of the block.  Otherwise set it to the end.
-    // Note that setting the insertion point causes the subsequent function
-    // call to check the existence of terminator in the newBlock.
-    builder->setInsertionPointToStart(newBlock);
-    if (blockIsUnterminated())
-      builder->setInsertionPointToEnd(newBlock);
-  }
-
-  /// Conditionally switch code insertion to a new block.
-  void maybeStartBlock(mlir::Block *newBlock) {
-    if (newBlock)
-      startBlock(newBlock);
-  }
-
-  /// Emit return and cleanup after the function has been translated.
-  void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
-    setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
-    if (funit.isMainProgram())
-      genExitRoutine();
-    else
-      genFIRProcedureExit(funit, funit.getSubprogramSymbol());
-    funit.finalBlock = nullptr;
-    LLVM_DEBUG(llvm::dbgs() << "*** Lowering result:\n\n"
-                            << *builder->getFunction() << '\n');
-    // FIXME: Simplification should happen in a normal pass, not here.
-    mlir::IRRewriter rewriter(*builder);
-    (void)mlir::simplifyRegions(rewriter,
-                                {builder->getRegion()}); // remove dead code
-    delete builder;
-    builder = nullptr;
-    hostAssocTuple = mlir::Value{};
-    localSymbols.clear();
-  }
-
-  /// Helper to generate GlobalOps when the builder is not positioned in any
-  /// region block. This is required because the FirOpBuilder assumes it is
-  /// always positioned inside a region block when creating globals, the easiest
-  /// way comply is to create a dummy function and to throw it afterwards.
-  void createGlobalOutsideOfFunctionLowering(
-      const std::function<void()> &createGlobals) {
-    // FIXME: get rid of the bogus function context and instantiate the
-    // globals directly into the module.
-    MLIRContext *context = &getMLIRContext();
-    mlir::FuncOp func = fir::FirOpBuilder::createFunction(
-        mlir::UnknownLoc::get(context), getModuleOp(),
-        fir::NameUniquer::doGenerated("Sham"),
-        mlir::FunctionType::get(context, llvm::None, llvm::None));
-    func.addEntryBlock();
-    builder = new fir::FirOpBuilder(func, bridge.getKindMap());
-    createGlobals();
-    if (mlir::Region *region = func.getCallableRegion())
-      region->dropAllReferences();
-    func.erase();
-    delete builder;
-    builder = nullptr;
-    localSymbols.clear();
-  }
-  /// Instantiate the data from a BLOCK DATA unit.
-  void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) {
-    createGlobalOutsideOfFunctionLowering([&]() {
-      Fortran::lower::AggregateStoreMap fakeMap;
-      for (const auto &[_, sym] : bdunit.symTab) {
-        if (sym->has<Fortran::semantics::ObjectEntityDetails>()) {
-          Fortran::lower::pft::Variable var(*sym, true);
-          instantiateVar(var, fakeMap);
-        }
-      }
-    });
-  }
-
-  /// Map mlir function block arguments to the corresponding Fortran dummy
-  /// variables. When the result is passed as a hidden argument, the Fortran
-  /// result is also mapped. The symbol map is used to hold this mapping.
-  void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,
-                            const Fortran::lower::CalleeInterface &callee) {
-    assert(builder && "require a builder object at this point");
-    using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;
-    auto mapPassedEntity = [&](const auto arg) -> void {
-      if (arg.passBy == PassBy::AddressAndLength) {
-        // TODO: now that fir call has some attributes regarding character
-        // return, PassBy::AddressAndLength should be retired.
-        mlir::Location loc = toLocation();
-        fir::factory::CharacterExprHelper charHelp{*builder, loc};
-        mlir::Value box =
-            charHelp.createEmboxChar(arg.firArgument, arg.firLength);
-        addSymbol(arg.entity->get(), box);
-      } else {
-        if (arg.entity.has_value()) {
-          addSymbol(arg.entity->get(), arg.firArgument);
-        } else {
-          assert(funit.parentHasHostAssoc());
-          funit.parentHostAssoc().internalProcedureBindings(*this,
-                                                            localSymbols);
-        }
-      }
-    };
-    for (const Fortran::lower::CalleeInterface::PassedEntity &arg :
-         callee.getPassedArguments())
-      mapPassedEntity(arg);
-
-    // Allocate local skeleton instances of dummies from other entry points.
-    // Most of these locals will not survive into final generated code, but
-    // some will.  It is illegal to reference them at run time if they do.
-    for (const Fortran::semantics::Symbol *arg :
-         funit.nonUniversalDummyArguments) {
-      if (lookupSymbol(*arg))
-        continue;
-      mlir::Type type = genType(*arg);
-      // TODO: Account for VALUE arguments (and possibly other variants).
-      type = builder->getRefType(type);
-      addSymbol(*arg, builder->create<fir::UndefOp>(toLocation(), type));
-    }
-    if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
-            passedResult = callee.getPassedResult()) {
-      mapPassedEntity(*passedResult);
-      // FIXME: need to make sure things are OK here. addSymbol may not be OK
-      if (funit.primaryResult &&
-          passedResult->entity->get() != *funit.primaryResult)
-        addSymbol(*funit.primaryResult,
-                  getSymbolAddress(passedResult->entity->get()));
-    }
-  }
-
-  /// Instantiate variable \p var and add it to the symbol map.
-  /// See ConvertVariable.cpp.
-  void instantiateVar(const Fortran::lower::pft::Variable &var,
-                      Fortran::lower::AggregateStoreMap &storeMap) {
-    Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);
-  }
-
-  /// Prepare to translate a new function
-  void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
-    assert(!builder && "expected nullptr");
-    Fortran::lower::CalleeInterface callee(funit, *this);
-    mlir::FuncOp func = callee.addEntryBlockAndMapArguments();
-    func.setVisibility(mlir::SymbolTable::Visibility::Public);
-    builder = new fir::FirOpBuilder(func, bridge.getKindMap());
-    assert(builder && "FirOpBuilder did not instantiate");
-    builder->setInsertionPointToStart(&func.front());
-
-    mapDummiesAndResults(funit, callee);
-
-    // Note: not storing Variable references because getOrderedSymbolTable
-    // below returns a temporary.
-    llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;
-
-    // Backup actual argument for entry character results
-    // with different lengths. It needs to be added to the non
-    // primary results symbol before mapSymbolAttributes is called.
-    Fortran::lower::SymbolBox resultArg;
-    if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
-            passedResult = callee.getPassedResult())
-      resultArg = lookupSymbol(passedResult->entity->get());
-
-    Fortran::lower::AggregateStoreMap storeMap;
-    // The front-end is currently not adding module variables referenced
-    // in a module procedure as host associated. As a result we need to
-    // instantiate all module variables here if this is a module procedure.
-    // It is likely that the front-end behavior should change here.
-    // This also applies to internal procedures inside module procedures.
-    if (auto *module = Fortran::lower::pft::getAncestor<
-            Fortran::lower::pft::ModuleLikeUnit>(funit))
-      for (const Fortran::lower::pft::Variable &var :
-           module->getOrderedSymbolTable())
-        instantiateVar(var, storeMap);
-
-    mlir::Value primaryFuncResultStorage;
-    for (const Fortran::lower::pft::Variable &var :
-         funit.getOrderedSymbolTable()) {
-      // Always instantiate aggregate storage blocks.
-      if (var.isAggregateStore()) {
-        instantiateVar(var, storeMap);
-        continue;
-      }
-      const Fortran::semantics::Symbol &sym = var.getSymbol();
-      if (funit.parentHasHostAssoc()) {
-        // Never instantitate host associated variables, as they are already
-        // instantiated from an argument tuple. Instead, just bind the symbol to
-        // the reference to the host variable, which must be in the map.
-        const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
-        if (funit.parentHostAssoc().isAssociated(ultimate)) {
-          Fortran::lower::SymbolBox hostBox =
-              localSymbols.lookupSymbol(ultimate);
-          assert(hostBox && "host association is not in map");
-          localSymbols.addSymbol(sym, hostBox.toExtendedValue());
-          continue;
-        }
-      }
-      if (!sym.IsFuncResult() || !funit.primaryResult) {
-        instantiateVar(var, storeMap);
-      } else if (&sym == funit.primaryResult) {
-        instantiateVar(var, storeMap);
-        primaryFuncResultStorage = getSymbolAddress(sym);
-      } else {
-        deferredFuncResultList.push_back(var);
-      }
-    }
-
-    // If this is a host procedure with host associations, then create the tuple
-    // of pointers for passing to the internal procedures.
-    if (!funit.getHostAssoc().empty())
-      funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);
-
-    /// TODO: should use same mechanism as equivalence?
-    /// One blocking point is character entry returns that need special handling
-    /// since they are not locally allocated but come as argument. CHARACTER(*)
-    /// is not something that fit wells with equivalence lowering.
-    for (const Fortran::lower::pft::Variable &altResult :
-         deferredFuncResultList) {
-      if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
-              passedResult = callee.getPassedResult())
-        addSymbol(altResult.getSymbol(), resultArg.getAddr());
-      Fortran::lower::StatementContext stmtCtx;
-      Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
-                                          stmtCtx, primaryFuncResultStorage);
-    }
-
-    // Create most function blocks in advance.
-    createEmptyGlobalBlocks(funit.evaluationList);
-
-    // Reinstate entry block as the current insertion point.
-    builder->setInsertionPointToEnd(&func.front());
-
-    if (callee.hasAlternateReturns()) {
-      // Create a local temp to hold the alternate return index.
-      // Give it an integer index type and the subroutine name (for dumps).
-      // Attach it to the subroutine symbol in the localSymbols map.
-      // Initialize it to zero, the "fallthrough" alternate return value.
-      const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();
-      mlir::Location loc = toLocation();
-      mlir::Type idxTy = builder->getIndexType();
-      mlir::Value altResult =
-          builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));
-      addSymbol(symbol, altResult);
-      mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
-      builder->create<fir::StoreOp>(loc, zero, altResult);
-    }
-
-    if (Fortran::lower::pft::Evaluation *alternateEntryEval =
-            funit.getEntryEval())
-      genFIRBranch(alternateEntryEval->lexicalSuccessor->block);
-  }
-
-  /// Create global blocks for the current function.  This eliminates the
-  /// distinction between forward and backward targets when generating
-  /// branches.  A block is "global" if it can be the target of a GOTO or
-  /// other source code branch.  A block that can only be targeted by a
-  /// compiler generated branch is "local".  For example, a DO loop preheader
-  /// block containing loop initialization code is global.  A loop header
-  /// block, which is the target of the loop back edge, is local.  Blocks
-  /// belong to a region.  Any block within a nested region must be replaced
-  /// with a block belonging to that region.  Branches may not cross region
-  /// boundaries.
-  void createEmptyGlobalBlocks(
-      std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
-    mlir::Region *region = &builder->getRegion();
-    for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
-      if (eval.isNewBlock)
-        eval.block = builder->createBlock(region);
-      if (eval.isConstruct() || eval.isDirective()) {
-        if (eval.lowerAsUnstructured()) {
-          createEmptyGlobalBlocks(eval.getNestedEvaluations());
-        } else if (eval.hasNestedEvaluations()) {
-          // A structured construct that is a target starts a new block.
-          Fortran::lower::pft::Evaluation &constructStmt =
-              eval.getFirstNestedEvaluation();
-          if (constructStmt.isNewBlock)
-            constructStmt.block = builder->createBlock(region);
-        }
-      }
-    }
-  }
-
-  /// Lower a procedure (nest).
-  void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
-    if (!funit.isMainProgram()) {
-      const Fortran::semantics::Symbol &procSymbol =
-          funit.getSubprogramSymbol();
-      if (procSymbol.owner().IsSubmodule()) {
-        TODO(toLocation(), "support submodules");
-        return;
-      }
-    }
-    setCurrentPosition(funit.getStartingSourceLoc());
-    for (int entryIndex = 0, last = funit.entryPointList.size();
-         entryIndex < last; ++entryIndex) {
-      funit.setActiveEntry(entryIndex);
-      startNewFunction(funit); // the entry point for lowering this procedure
-      for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)
-        genFIR(eval);
-      endNewFunction(funit);
-    }
-    funit.setActiveEntry(0);
-    for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
-      lowerFunc(f); // internal procedure
-  }
-
-  /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC
-  /// declarative construct.
-  void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {
-    setCurrentPosition(mod.getStartingSourceLoc());
-    createGlobalOutsideOfFunctionLowering([&]() {
-      for (const Fortran::lower::pft::Variable &var :
-           mod.getOrderedSymbolTable()) {
-        // Only define the variables owned by this module.
-        const Fortran::semantics::Scope *owningScope = var.getOwningScope();
-        if (!owningScope || mod.getScope() == *owningScope)
-          Fortran::lower::defineModuleVariable(*this, var);
-      }
-      for (auto &eval : mod.evaluationList)
-        genFIR(eval);
-    });
-  }
-
-  /// Lower functions contained in a module.
-  void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {
-    for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions)
-      lowerFunc(f);
-  }
-
   mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
 
   /// Record a binding for the ssa-value of the tuple for this function.
   void bindHostAssocTuple(mlir::Value val) override final {
     assert(!hostAssocTuple && val);
     hostAssocTuple = val;
   }
 
private:
   bool addSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val,
                  bool forced = false) {
     if (!forced && lookupSymbol(sym))
       return false;
     localSymbols.addSymbol(sym, val, forced);
     return true;
   }
 
-  bool isNumericScalarCategory(Fortran::common::TypeCategory cat) {
+  bool addCharSymbol(const Fortran::semantics::SymbolRef sym, mlir::Value val,
+                     mlir::Value len, bool forced = false) {
+    if (!forced && lookupSymbol(sym))
+      return false;
+    // TODO: ensure val type is fir.array<len x fir.char<kind>> like. Insert
+    // cast if needed.
+    localSymbols.addCharSymbol(sym, val, len, forced);
+    return true;
+  }
+
+  fir::ExtendedValue getExtendedValue(Fortran::lower::SymbolBox sb) {
+    return sb.match(
+        [&](const Fortran::lower::SymbolBox::PointerOrAllocatable &box) {
+          return fir::factory::genMutableBoxRead(*builder, getCurrentLocation(),
+                                                 box);
+        },
+        [&sb](auto &) { return sb.toExtendedValue(); });
+  }
+
+  static bool isNumericScalarCategory(Fortran::common::TypeCategory cat) {
     return cat == Fortran::common::TypeCategory::Integer ||
            cat == Fortran::common::TypeCategory::Real ||
            cat == Fortran::common::TypeCategory::Complex ||
            cat == Fortran::common::TypeCategory::Logical;
   }
   static bool isLogicalCategory(Fortran::common::TypeCategory cat) {
     return cat == Fortran::common::TypeCategory::Logical;
   }
-  bool isCharacterCategory(Fortran::common::TypeCategory cat) {
+  static bool isCharacterCategory(Fortran::common::TypeCategory cat) {
     return cat == Fortran::common::TypeCategory::Character;
   }
-  bool isDerivedCategory(Fortran::common::TypeCategory cat) {
+  static bool isDerivedCategory(Fortran::common::TypeCategory cat) {
     return cat == Fortran::common::TypeCategory::Derived;
   }
 
   /// Insert a new block before \p block.  Leave the insertion point unchanged.
   mlir::Block *insertBlock(mlir::Block *block) {
     mlir::OpBuilder::InsertPoint insertPt = builder->saveInsertionPoint();
     mlir::Block *newBlock = builder->createBlock(block);
     builder->restoreInsertionPoint(insertPt);
     return newBlock;
   }
 
   mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval,
                             Fortran::parser::Label label) {
     const Fortran::lower::pft::LabelEvalMap &labelEvaluationMap =
         eval.getOwningProcedure()->labelEvaluationMap;
     const auto iter = labelEvaluationMap.find(label);
     assert(iter != labelEvaluationMap.end() && "label missing from map");
     mlir::Block *block = iter->second->block;
     assert(block && "missing labeled evaluation block");
     return block;
   }
 
   void genFIRBranch(mlir::Block *targetBlock) {
     assert(targetBlock && "missing unconditional target block");
-    builder->create<cf::BranchOp>(toLocation(), targetBlock);
+    builder->create<mlir::cf::BranchOp>(toLocation(), targetBlock);
   }
 
   void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget,
                                mlir::Block *falseTarget) {
     assert(trueTarget && "missing conditional branch true block");
     assert(falseTarget && "missing conditional branch false block");
     mlir::Location loc = toLocation();
     mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond);
mlir::Value genIfCondition(const A *stmt, bool negate = false) {
     mlir::Value cond =
         builder->createConvert(loc, builder->getI1Type(), condExpr);
     if (negate)
       cond = builder->create<mlir::arith::XOrIOp>(
           loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1));
     return cond;
   }
 
-  static bool
-  isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) {
-    return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
-           !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
-           !Fortran::evaluate::HasVectorSubscript(expr);
-  }
-
-  [[maybe_unused]] static bool
-  isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
-    const Fortran::semantics::Symbol *sym =
-        Fortran::evaluate::GetFirstSymbol(expr);
-    return sym && sym->IsFuncResult();
-  }
-
-  static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
-    const Fortran::semantics::Symbol *sym =
-        Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr);
-    return sym && Fortran::semantics::IsAllocatable(*sym);
-  }
-
-  /// Shared for both assignments and pointer assignments.
-  void genAssignment(const Fortran::evaluate::Assignment &assign) {
-    Fortran::lower::StatementContext stmtCtx;
-    mlir::Location loc = toLocation();
-    if (explicitIterationSpace()) {
-      Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols);
-      explicitIterSpace.genLoopNest();
-    }
-    std::visit(
-        Fortran::common::visitors{
-            // [1] Plain old assignment.
-            [&](const Fortran::evaluate::Assignment::Intrinsic &) {
-              const Fortran::semantics::Symbol *sym =
-                  Fortran::evaluate::GetLastSymbol(assign.lhs);
-
-              if (!sym)
-                TODO(loc, "assignment to pointer result of function reference");
-
-              std::optional<Fortran::evaluate::DynamicType> lhsType =
-                  assign.lhs.GetType();
-              assert(lhsType && "lhs cannot be typeless");
-              // Assignment to polymorphic allocatables may require changing the
-              // variable dynamic type (See Fortran 2018 10.2.1.3 p3).
-              if (lhsType->IsPolymorphic() && isWholeAllocatable(assign.lhs))
-                TODO(loc, "assignment to polymorphic allocatable");
-
-              // Note: No ad-hoc handling for pointers is required here. The
-              // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr
-              // on a pointer returns the target address and not the address of
-              // the pointer variable.
-
-              if (assign.lhs.Rank() > 0 || explicitIterationSpace()) {
-                // Array assignment
-                // See Fortran 2018 10.2.1.3 p5, p6, and p7
-                genArrayAssignment(assign, stmtCtx);
-                return;
-              }
-
-              // 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(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())) {
-                // Fortran 2018 10.2.1.3 p10 and p11
-                fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
-                    lhs, rhs);
-              } else if (isDerivedCategory(lhsType->category())) {
-                // Fortran 2018 10.2.1.3 p13 and p14
-                // Recursively gen an assignment on each element pair.
-                fir::factory::genRecordAssignment(*builder, loc, lhs, rhs);
-              } 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) {
-              Fortran::lower::StatementContext &ctx =
-                  explicitIterationSpace() ? explicitIterSpace.stmtContext()
-                                           : stmtCtx;
-              Fortran::lower::createSubroutineCall(
-                  *this, procRef, explicitIterSpace, implicitIterSpace,
-                  localSymbols, ctx, /*isUserDefAssignment=*/true);
-            },
-
-            // [3] Pointer assignment with possibly empty bounds-spec. R1035: a
-            // bounds-spec is a lower bound value.
-            [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
-              if (IsProcedure(assign.rhs))
-                TODO(loc, "procedure pointer assignment");
-              std::optional<Fortran::evaluate::DynamicType> lhsType =
-                  assign.lhs.GetType();
-              std::optional<Fortran::evaluate::DynamicType> rhsType =
-                  assign.rhs.GetType();
-              // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
-              if ((lhsType && lhsType->IsPolymorphic()) ||
-                  (rhsType && rhsType->IsPolymorphic()))
-                TODO(loc, "pointer assignment involving polymorphic entity");
-
-              // FIXME: in the explicit space context, we want to use
-              // ScalarArrayExprLowering here.
-              fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
-              llvm::SmallVector<mlir::Value> lbounds;
-              for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
-                lbounds.push_back(
-                    fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
-              Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs,
-                                                  lbounds, stmtCtx);
-              if (explicitIterationSpace()) {
-                mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
-                if (!inners.empty()) {
-                  // TODO: should force a copy-in/copy-out here.
-                  // e.g., obj%ptr(i+1) => obj%ptr(i)
-                  builder->create<fir::ResultOp>(loc, inners);
-                }
-              }
-            },
-
-            // [4] Pointer assignment with bounds-remapping. R1036: a
-            // bounds-remapping is a pair, lower bound and upper bound.
-            [&](const Fortran::evaluate::Assignment::BoundsRemapping
-                    &boundExprs) {
-              std::optional<Fortran::evaluate::DynamicType> lhsType =
-                  assign.lhs.GetType();
-              std::optional<Fortran::evaluate::DynamicType> rhsType =
-                  assign.rhs.GetType();
-              // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
-              if ((lhsType && lhsType->IsPolymorphic()) ||
-                  (rhsType && rhsType->IsPolymorphic()))
-                TODO(loc, "pointer assignment involving polymorphic entity");
-
-              // FIXME: in the explicit space context, we want to use
-              // ScalarArrayExprLowering here.
-              fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
-              if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
-                      assign.rhs)) {
-                fir::factory::disassociateMutableBox(*builder, loc, lhs);
-                return;
-              }
-              llvm::SmallVector<mlir::Value> lbounds;
-              llvm::SmallVector<mlir::Value> ubounds;
-              for (const std::pair<Fortran::evaluate::ExtentExpr,
-                                   Fortran::evaluate::ExtentExpr> &pair :
-                   boundExprs) {
-                const Fortran::evaluate::ExtentExpr &lbExpr = pair.first;
-                const Fortran::evaluate::ExtentExpr &ubExpr = pair.second;
-                lbounds.push_back(
-                    fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
-                ubounds.push_back(
-                    fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx)));
-              }
-              // Do not generate a temp in case rhs is an array section.
-              fir::ExtendedValue rhs =
-                  isArraySectionWithoutVectorSubscript(assign.rhs)
-                      ? Fortran::lower::createSomeArrayBox(
-                            *this, assign.rhs, localSymbols, stmtCtx)
-                      : genExprAddr(assign.rhs, stmtCtx);
-              fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs,
-                                                         rhs, lbounds, ubounds);
-              if (explicitIterationSpace()) {
-                mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
-                if (!inners.empty()) {
-                  // TODO: should force a copy-in/copy-out here.
-                  // e.g., obj%ptr(i+1) => obj%ptr(i)
-                  builder->create<fir::ResultOp>(loc, inners);
-                }
-              }
-            },
-        },
-        assign.u);
-    if (explicitIterationSpace())
-      Fortran::lower::createArrayMergeStores(*this, explicitIterSpace);
+  mlir::FuncOp getFunc(llvm::StringRef name, mlir::FunctionType ty) {
+    if (mlir::FuncOp func = builder->getNamedFunction(name)) {
+      assert(func.getFunctionType() == ty);
+      return func;
+    return builder->createFunction(toLocation(), name, ty);
   }
 
   /// Lowering of CALL statement
   void genFIR(const Fortran::parser::CallStmt &stmt) {
     Fortran::lower::StatementContext stmtCtx;
     Fortran::lower::pft::Evaluation &eval = getEval();
     setCurrentPosition(stmt.v.source);
     assert(stmt.typedCall && "Call was not analyzed");
mlir::Value expr = createFIRExpr(
         Fortran::semantics::GetExpr(std::get<Fortran::parser::Expr>(stmt.t)),
         stmtCtx);
     stmtCtx.finalize();
     mlir::Type exprType = expr.getType();
     mlir::Location loc = toLocation();
     if (exprType.isSignlessInteger()) {
       // Arithmetic expression has Integer type.  Generate a SelectCaseOp
       // with ranges {(-inf:-1], 0=default, [1:inf)}.
-      MLIRContext *context = builder->getContext();
+      mlir::MLIRContext *context = builder->getContext();
       llvm::SmallVector<mlir::Attribute> attrList;
       llvm::SmallVector<mlir::Value> valueList;
       llvm::SmallVector<mlir::Block *> blockList;
       attrList.push_back(fir::UpperBoundAttr::get(context));
       valueList.push_back(builder->createIntegerConstant(loc, exprType, -1));
       blockList.push_back(blockOfLabel(eval, std::get<1>(stmt.t)));
       attrList.push_back(fir::LowerBoundAttr::get(context));
       valueList.push_back(builder->createIntegerConstant(loc, exprType, 1));
if (indexList.empty())
       for (auto &label : labelSet)
         addLabel(label);
     // Add a nop/fallthrough branch to the switch for a nonconforming program
     // unit that violates the program requirement above.
     blockList.push_back(eval.nonNopSuccessor().block); // default
     builder->create<fir::SelectOp>(loc, selectExpr, indexList, blockList);
   }
 
+  /// Generate FIR for a DO construct.  There are six variants:
+  ///  - unstructured infinite and while loops
+  ///  - structured and unstructured increment loops
+  ///  - structured and unstructured concurrent loops
   void genFIR(const Fortran::parser::DoConstruct &doConstruct) {
     TODO(toLocation(), "DoConstruct lowering");
   }
 
+  /// Generate structured or unstructured FIR for an IF construct.
+  /// The initial statement may be either an IfStmt or an IfThenStmt.
   void genFIR(const Fortran::parser::IfConstruct &) {
     mlir::Location loc = toLocation();
     Fortran::lower::pft::Evaluation &eval = getEval();
     if (eval.lowerAsStructured()) {
       // Structured fir.if nest.
       fir::IfOp topIfOp, currentIfOp;
       for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
         auto genIfOp = [&](mlir::Value cond) {
void genFIR(const Fortran::parser::OpenMPConstruct &omp) {
     Fortran::lower::genOpenMPConstruct(*this, getEval(), omp);
 
     for (Fortran::lower::pft::Evaluation &e : getEval().getNestedEvaluations())
       genFIR(e);
     localSymbols.popScope();
     builder->restoreInsertionPoint(insertPt);
   }
 
-  void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &) {
+  void genFIR(const Fortran::parser::OpenMPDeclarativeConstruct &ompDecl) {
     TODO(toLocation(), "OpenMPDeclarativeConstruct lowering");
   }
 
   /// Generate FIR for a SELECT CASE statement.
   /// The type may be CHARACTER, INTEGER, or LOGICAL.
   void genFIR(const Fortran::parser::SelectCaseStmt &stmt) {
     Fortran::lower::pft::Evaluation &eval = getEval();
-    MLIRContext *context = builder->getContext();
+    mlir::MLIRContext *context = builder->getContext();
     mlir::Location loc = toLocation();
     Fortran::lower::StatementContext stmtCtx;
     const Fortran::lower::SomeExpr *expr = Fortran::semantics::GetExpr(
         std::get<Fortran::parser::Scalar<Fortran::parser::Expr>>(stmt.t));
     bool isCharSelector = isCharacterCategory(expr->GetType()->category());
     bool isLogicalSelector = isLogicalCategory(expr->GetType()->category());
     auto charValue = [&](const Fortran::lower::SomeExpr *expr) {
       fir::ExtendedValue exv = genExprAddr(*expr, stmtCtx, &loc);
for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
         localSymbols.popScope();
       } else {
         genFIR(e);
       }
     }
   }
 
   void genFIR(const Fortran::parser::BlockConstruct &blockConstruct) {
+    setCurrentPositionAt(blockConstruct);
     TODO(toLocation(), "BlockConstruct lowering");
   }
-
   void genFIR(const Fortran::parser::BlockStmt &) {
     TODO(toLocation(), "BlockStmt lowering");
   }
-
   void genFIR(const Fortran::parser::EndBlockStmt &) {
     TODO(toLocation(), "EndBlockStmt lowering");
   }
 
   void genFIR(const Fortran::parser::ChangeTeamConstruct &construct) {
     TODO(toLocation(), "ChangeTeamConstruct lowering");
   }
-
   void genFIR(const Fortran::parser::ChangeTeamStmt &stmt) {
     TODO(toLocation(), "ChangeTeamStmt lowering");
   }
-
   void genFIR(const Fortran::parser::EndChangeTeamStmt &stmt) {
     TODO(toLocation(), "EndChangeTeamStmt lowering");
   }
 
   void genFIR(const Fortran::parser::CriticalConstruct &criticalConstruct) {
+    setCurrentPositionAt(criticalConstruct);
     TODO(toLocation(), "CriticalConstruct lowering");
   }
-
   void genFIR(const Fortran::parser::CriticalStmt &) {
     TODO(toLocation(), "CriticalStmt lowering");
   }
-
   void genFIR(const Fortran::parser::EndCriticalStmt &) {
     TODO(toLocation(), "EndCriticalStmt lowering");
   }
 
   void genFIR(const Fortran::parser::SelectRankConstruct &selectRankConstruct) {
+    setCurrentPositionAt(selectRankConstruct);
     TODO(toLocation(), "SelectRankConstruct lowering");
   }
-
   void genFIR(const Fortran::parser::SelectRankStmt &) {
     TODO(toLocation(), "SelectRankStmt lowering");
   }
-
   void genFIR(const Fortran::parser::SelectRankCaseStmt &) {
     TODO(toLocation(), "SelectRankCaseStmt lowering");
   }
 
   void genFIR(const Fortran::parser::SelectTypeConstruct &selectTypeConstruct) {
+    setCurrentPositionAt(selectTypeConstruct);
     TODO(toLocation(), "SelectTypeConstruct lowering");
   }
-
   void genFIR(const Fortran::parser::SelectTypeStmt &) {
     TODO(toLocation(), "SelectTypeStmt lowering");
   }
-
   void genFIR(const Fortran::parser::TypeGuardStmt &) {
     TODO(toLocation(), "TypeGuardStmt lowering");
   }
 
   //===--------------------------------------------------------------------===//
   // IO statements (see io.h)
   //===--------------------------------------------------------------------===//
 
   void genFIR(const Fortran::parser::BackspaceStmt &stmt) {
     mlir::Value iostat = genBackspaceStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.v, iostat);
   }
-
   void genFIR(const Fortran::parser::CloseStmt &stmt) {
     mlir::Value iostat = genCloseStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.v, iostat);
   }
-
   void genFIR(const Fortran::parser::EndfileStmt &stmt) {
     mlir::Value iostat = genEndfileStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.v, iostat);
   }
-
   void genFIR(const Fortran::parser::FlushStmt &stmt) {
     mlir::Value iostat = genFlushStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.v, iostat);
   }
-
   void genFIR(const Fortran::parser::InquireStmt &stmt) {
     mlir::Value iostat = genInquireStatement(*this, stmt);
     if (const auto *specs =
             std::get_if<std::list<Fortran::parser::InquireSpec>>(&stmt.u))
       genIoConditionBranches(getEval(), *specs, iostat);
   }
-
   void genFIR(const Fortran::parser::OpenStmt &stmt) {
     mlir::Value iostat = genOpenStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.v, iostat);
   }
-
   void genFIR(const Fortran::parser::PrintStmt &stmt) {
     genPrintStatement(*this, stmt);
   }
-
   void genFIR(const Fortran::parser::ReadStmt &stmt) {
     mlir::Value iostat = genReadStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.controls, iostat);
   }
-
   void genFIR(const Fortran::parser::RewindStmt &stmt) {
     mlir::Value iostat = genRewindStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.v, iostat);
   }
-
   void genFIR(const Fortran::parser::WaitStmt &stmt) {
     mlir::Value iostat = genWaitStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.v, iostat);
   }
-
   void genFIR(const Fortran::parser::WriteStmt &stmt) {
     mlir::Value iostat = genWriteStatement(*this, stmt);
     genIoConditionBranches(getEval(), stmt.controls, iostat);
   }
 
   template <typename A>
   void genIoConditionBranches(Fortran::lower::pft::Evaluation &eval,
                               const A &specList, mlir::Value iostat) {

   void genFIR(const Fortran::parser::FormTeamStmt &stmt) {
     TODO(toLocation(), "FormTeamStmt lowering");
   }
 
   void genFIR(const Fortran::parser::LockStmt &stmt) {
     TODO(toLocation(), "LockStmt lowering");
   }
 
+  fir::ExtendedValue
+  genInitializerExprValue(const Fortran::lower::SomeExpr &expr,
+                          Fortran::lower::StatementContext &stmtCtx) {
+    return Fortran::lower::createSomeInitializerExpression(
+        toLocation(), *this, expr, localSymbols, stmtCtx);
+  }
+
   /// Return true if the current context is a conditionalized and implied
   /// iteration space.
   bool implicitIterationSpace() { return !implicitIterSpace.empty(); }
 
   /// Return true if context is currently an explicit iteration space. A scalar
   /// assignment expression may be contextually within a user-defined iteration
   /// space, transforming it into an array expression.
   bool explicitIterationSpace() { return explicitIterSpace.isActive(); }
void genArrayAssignment(const Fortran::evaluate::Assignment &assign,
     // implied by the lhs array expression.
     Fortran::lower::createAnyMaskedArrayAssignment(
         *this, assign.lhs, assign.rhs, explicitIterSpace, implicitIterSpace,
         localSymbols,
         explicitIterationSpace() ? explicitIterSpace.stmtContext()
                                  : implicitIterSpace.stmtContext());
   }
 
+  static bool
+  isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) {
+    return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
+           !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
+           !Fortran::evaluate::HasVectorSubscript(expr);
+  }
+
+#if !defined(NDEBUG)
+  static bool isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
+    const Fortran::semantics::Symbol *sym =
+        Fortran::evaluate::GetFirstSymbol(expr);
+    return sym && sym->IsFuncResult();
+  }
+#endif
+
+  static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
+    const Fortran::semantics::Symbol *sym =
+        Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr);
+    return sym && Fortran::semantics::IsAllocatable(*sym);
+  }
+
+  /// Shared for both assignments and pointer assignments.
+  void genAssignment(const Fortran::evaluate::Assignment &assign) {
+    Fortran::lower::StatementContext stmtCtx;
+    mlir::Location loc = toLocation();
+    if (explicitIterationSpace()) {
+      Fortran::lower::createArrayLoads(*this, explicitIterSpace, localSymbols);
+      explicitIterSpace.genLoopNest();
+    }
+    std::visit(
+        Fortran::common::visitors{
+            // [1] Plain old assignment.
+            [&](const Fortran::evaluate::Assignment::Intrinsic &) {
+              const Fortran::semantics::Symbol *sym =
+                  Fortran::evaluate::GetLastSymbol(assign.lhs);
+
+              if (!sym)
+                TODO(loc, "assignment to pointer result of function reference");
+
+              std::optional<Fortran::evaluate::DynamicType> lhsType =
+                  assign.lhs.GetType();
+              assert(lhsType && "lhs cannot be typeless");
+              // Assignment to polymorphic allocatables may require changing the
+              // variable dynamic type (See Fortran 2018 10.2.1.3 p3).
+              if (lhsType->IsPolymorphic() && isWholeAllocatable(assign.lhs))
+                TODO(loc, "assignment to polymorphic allocatable");
+
+              // Note: No ad-hoc handling for pointers is required here. The
+              // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr
+              // on a pointer returns the target address and not the address of
+              // the pointer variable.
+
+              if (assign.lhs.Rank() > 0 || explicitIterationSpace()) {
+                // Array assignment
+                // See Fortran 2018 10.2.1.3 p5, p6, and p7
+                genArrayAssignment(assign, stmtCtx);
+                return;
+              }
+
+              // 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(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())) {
+                // Fortran 2018 10.2.1.3 p10 and p11
+                fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
+                    lhs, rhs);
+              } else if (isDerivedCategory(lhsType->category())) {
+                // Fortran 2018 10.2.1.3 p13 and p14
+                // Recursively gen an assignment on each element pair.
+                fir::factory::genRecordAssignment(*builder, loc, lhs, rhs);
+              } 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) {
+              Fortran::lower::StatementContext &ctx =
+                  explicitIterationSpace() ? explicitIterSpace.stmtContext()
+                                           : stmtCtx;
+              Fortran::lower::createSubroutineCall(
+                  *this, procRef, explicitIterSpace, implicitIterSpace,
+                  localSymbols, ctx, /*isUserDefAssignment=*/true);
+            },
+
+            // [3] Pointer assignment with possibly empty bounds-spec. R1035: a
+            // bounds-spec is a lower bound value.
+            [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
+              if (IsProcedure(assign.rhs))
+                TODO(loc, "procedure pointer assignment");
+              std::optional<Fortran::evaluate::DynamicType> lhsType =
+                  assign.lhs.GetType();
+              std::optional<Fortran::evaluate::DynamicType> rhsType =
+                  assign.rhs.GetType();
+              // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
+              if ((lhsType && lhsType->IsPolymorphic()) ||
+                  (rhsType && rhsType->IsPolymorphic()))
+                TODO(loc, "pointer assignment involving polymorphic entity");
+
+              // FIXME: in the explicit space context, we want to use
+              // ScalarArrayExprLowering here.
+              fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
+              llvm::SmallVector<mlir::Value> lbounds;
+              for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
+                lbounds.push_back(
+                    fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
+              Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs,
+                                                  lbounds, stmtCtx);
+              if (explicitIterationSpace()) {
+                mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
+                if (!inners.empty()) {
+                  // TODO: should force a copy-in/copy-out here.
+                  // e.g., obj%ptr(i+1) => obj%ptr(i)
+                  builder->create<fir::ResultOp>(loc, inners);
+                }
+              }
+            },
+
+            // [4] Pointer assignment with bounds-remapping. R1036: a
+            // bounds-remapping is a pair, lower bound and upper bound.
+            [&](const Fortran::evaluate::Assignment::BoundsRemapping
+                    &boundExprs) {
+              std::optional<Fortran::evaluate::DynamicType> lhsType =
+                  assign.lhs.GetType();
+              std::optional<Fortran::evaluate::DynamicType> rhsType =
+                  assign.rhs.GetType();
+              // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
+              if ((lhsType && lhsType->IsPolymorphic()) ||
+                  (rhsType && rhsType->IsPolymorphic()))
+                TODO(loc, "pointer assignment involving polymorphic entity");
+
+              // FIXME: in the explicit space context, we want to use
+              // ScalarArrayExprLowering here.
+              fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
+              if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
+                      assign.rhs)) {
+                fir::factory::disassociateMutableBox(*builder, loc, lhs);
+                return;
+              }
+              llvm::SmallVector<mlir::Value> lbounds;
+              llvm::SmallVector<mlir::Value> ubounds;
+              for (const std::pair<Fortran::evaluate::ExtentExpr,
+                                   Fortran::evaluate::ExtentExpr> &pair :
+                   boundExprs) {
+                const Fortran::evaluate::ExtentExpr &lbExpr = pair.first;
+                const Fortran::evaluate::ExtentExpr &ubExpr = pair.second;
+                lbounds.push_back(
+                    fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
+                ubounds.push_back(
+                    fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx)));
+              }
+              // Do not generate a temp in case rhs is an array section.
+              fir::ExtendedValue rhs =
+                  isArraySectionWithoutVectorSubscript(assign.rhs)
+                      ? Fortran::lower::createSomeArrayBox(
+                            *this, assign.rhs, localSymbols, stmtCtx)
+                      : genExprAddr(assign.rhs, stmtCtx);
+              fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs,
+                                                         rhs, lbounds, ubounds);
+              if (explicitIterationSpace()) {
+                mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
+                if (!inners.empty()) {
+                  // TODO: should force a copy-in/copy-out here.
+                  // e.g., obj%ptr(i+1) => obj%ptr(i)
+                  builder->create<fir::ResultOp>(loc, inners);
+                }
+              }
+            },
+        },
+        assign.u);
+    if (explicitIterationSpace())
+      Fortran::lower::createArrayMergeStores(*this, explicitIterSpace);
+  }
+
   void genFIR(const Fortran::parser::WhereConstruct &c) {
     implicitIterSpace.growStack();
     genNestedStatement(
         std::get<
             Fortran::parser::Statement<Fortran::parser::WhereConstructStmt>>(
             c.t));
     for (const auto &body :
          std::get<std::list<Fortran::parser::WhereBodyConstruct>>(c.t))
void genFIR(const Fortran::parser::FormatStmt &) {
     // FORMAT statements have no semantics. They may be lowered if used by a
     // data transfer statement.
   }
 
   void genFIR(const Fortran::parser::PauseStmt &stmt) {
     genPauseStatement(*this, stmt);
   }
 
+  // call FAIL IMAGE in runtime
   void genFIR(const Fortran::parser::FailImageStmt &stmt) {
     TODO(toLocation(), "FailImageStmt lowering");
   }
 
   // call STOP, ERROR STOP in runtime
   void genFIR(const Fortran::parser::StopStmt &stmt) {
     genStopStatement(*this, stmt);
   }
if (!funit->finalBlock) {
       mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint();
       funit->finalBlock = builder->createBlock(&builder->getRegion());
       builder->restoreInsertionPoint(insPt);
     }
     builder->create<mlir::cf::BranchOp>(loc, funit->finalBlock);
   }
 
   void genFIR(const Fortran::parser::CycleStmt &) {
-    TODO(toLocation(), "CycleStmt lowering");
+    genFIRBranch(getEval().controlSuccessor->block);
   }
-
   void genFIR(const Fortran::parser::ExitStmt &) {
-    TODO(toLocation(), "ExitStmt lowering");
+    genFIRBranch(getEval().controlSuccessor->block);
   }
-
   void genFIR(const Fortran::parser::GotoStmt &) {
     genFIRBranch(getEval().controlSuccessor->block);
   }
 
-  void genFIR(const Fortran::parser::ElseIfStmt &) {
-    TODO(toLocation(), "ElseIfStmt lowering");
-  }
-
-  void genFIR(const Fortran::parser::ElseStmt &) {
-    TODO(toLocation(), "ElseStmt lowering");
-  }
-
   void genFIR(const Fortran::parser::EndDoStmt &) {
     TODO(toLocation(), "EndDoStmt lowering");
   }
 
-  void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {
-    TODO(toLocation(), "EndMpSubprogramStmt lowering");
-  }
-
   // Nop statements - No code, or code is generated at the construct level.
-  void genFIR(const Fortran::parser::AssociateStmt &) {}     // nop
-  void genFIR(const Fortran::parser::CaseStmt &) {}          // nop
-  void genFIR(const Fortran::parser::ContinueStmt &) {}      // nop
-  void genFIR(const Fortran::parser::EndAssociateStmt &) {}  // nop
-  void genFIR(const Fortran::parser::EndFunctionStmt &) {}   // nop
-  void genFIR(const Fortran::parser::EndIfStmt &) {}         // nop
-  void genFIR(const Fortran::parser::EndSelectStmt &) {}     // nop
-  void genFIR(const Fortran::parser::EndSubroutineStmt &) {} // nop
-  void genFIR(const Fortran::parser::EntryStmt &) {}         // nop
-
-  void genFIR(const Fortran::parser::IfStmt &) {
-    TODO(toLocation(), "IfStmt lowering");
-  }
-
-  void genFIR(const Fortran::parser::IfThenStmt &) {
-    TODO(toLocation(), "IfThenStmt lowering");
-  }
+  void genFIR(const Fortran::parser::AssociateStmt &) {}       // nop
+  void genFIR(const Fortran::parser::CaseStmt &) {}            // nop
+  void genFIR(const Fortran::parser::ContinueStmt &) {}        // nop
+  void genFIR(const Fortran::parser::ElseIfStmt &) {}          // nop
+  void genFIR(const Fortran::parser::ElseStmt &) {}            // nop
+  void genFIR(const Fortran::parser::EndAssociateStmt &) {}    // nop
+  void genFIR(const Fortran::parser::EndFunctionStmt &) {}     // nop
+  void genFIR(const Fortran::parser::EndIfStmt &) {}           // nop
+  void genFIR(const Fortran::parser::EndMpSubprogramStmt &) {} // nop
+  void genFIR(const Fortran::parser::EndSelectStmt &) {}       // nop
+  void genFIR(const Fortran::parser::EndSubroutineStmt &) {}   // nop
+  void genFIR(const Fortran::parser::EntryStmt &) {}           // nop
+  void genFIR(const Fortran::parser::IfStmt &) {}              // nop
+  void genFIR(const Fortran::parser::IfThenStmt &) {}          // nop
 
   void genFIR(const Fortran::parser::NonLabelDoStmt &) {
     TODO(toLocation(), "NonLabelDoStmt lowering");
   }
 
   void genFIR(const Fortran::parser::OmpEndLoopDirective &) {
     TODO(toLocation(), "OmpEndLoopDirective lowering");
   }
if (unstructuredContext && blockIsUnterminated()) {
                eval.getLastNestedEvaluation()
                    .lexicalSuccessor->isIntermediateConstructStmt())
         successor = eval.constructExit;
       if (successor && successor->block)
         genFIRBranch(successor->block);
     }
   }
 
+  /// Map mlir function block arguments to the corresponding Fortran dummy
+  /// variables. When the result is passed as a hidden argument, the Fortran
+  /// result is also mapped. The symbol map is used to hold this mapping.
+  void mapDummiesAndResults(Fortran::lower::pft::FunctionLikeUnit &funit,
+                            const Fortran::lower::CalleeInterface &callee) {
+    assert(builder && "require a builder object at this point");
+    using PassBy = Fortran::lower::CalleeInterface::PassEntityBy;
+    auto mapPassedEntity = [&](const auto arg) -> void {
+      if (arg.passBy == PassBy::AddressAndLength) {
+        // TODO: now that fir call has some attributes regarding character
+        // return, PassBy::AddressAndLength should be retired.
+        mlir::Location loc = toLocation();
+        fir::factory::CharacterExprHelper charHelp{*builder, loc};
+        mlir::Value box =
+            charHelp.createEmboxChar(arg.firArgument, arg.firLength);
+        addSymbol(arg.entity->get(), box);
+      } else {
+        if (arg.entity.has_value()) {
+          addSymbol(arg.entity->get(), arg.firArgument);
+        } else {
+          assert(funit.parentHasHostAssoc());
+          funit.parentHostAssoc().internalProcedureBindings(*this,
+                                                            localSymbols);
+        }
+      }
+    };
+    for (const Fortran::lower::CalleeInterface::PassedEntity &arg :
+         callee.getPassedArguments())
+      mapPassedEntity(arg);
+
+    // Allocate local skeleton instances of dummies from other entry points.
+    // Most of these locals will not survive into final generated code, but
+    // some will.  It is illegal to reference them at run time if they do.
+    for (const Fortran::semantics::Symbol *arg :
+         funit.nonUniversalDummyArguments) {
+      if (lookupSymbol(*arg))
+        continue;
+      mlir::Type type = genType(*arg);
+      // TODO: Account for VALUE arguments (and possibly other variants).
+      type = builder->getRefType(type);
+      addSymbol(*arg, builder->create<fir::UndefOp>(toLocation(), type));
+    }
+    if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
+            passedResult = callee.getPassedResult()) {
+      mapPassedEntity(*passedResult);
+      // FIXME: need to make sure things are OK here. addSymbol may not be OK
+      if (funit.primaryResult &&
+          passedResult->entity->get() != *funit.primaryResult)
+        addSymbol(*funit.primaryResult,
+                  getSymbolAddress(passedResult->entity->get()));
+    }
+  }
+
+  /// Instantiate variable \p var and add it to the symbol map.
+  /// See ConvertVariable.cpp.
+  void instantiateVar(const Fortran::lower::pft::Variable &var,
+                      Fortran::lower::AggregateStoreMap &storeMap) {
+    Fortran::lower::instantiateVariable(*this, var, localSymbols, storeMap);
+  }
+
+  /// Prepare to translate a new function
+  void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
+    assert(!builder && "expected nullptr");
+    Fortran::lower::CalleeInterface callee(funit, *this);
+    mlir::FuncOp func = callee.addEntryBlockAndMapArguments();
+    builder = new fir::FirOpBuilder(func, bridge.getKindMap());
+    assert(builder && "FirOpBuilder did not instantiate");
+    builder->setInsertionPointToStart(&func.front());
+    func.setVisibility(mlir::SymbolTable::Visibility::Public);
+
+    mapDummiesAndResults(funit, callee);
+
+    // Note: not storing Variable references because getOrderedSymbolTable
+    // below returns a temporary.
+    llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;
+
+    // Backup actual argument for entry character results
+    // with different lengths. It needs to be added to the non
+    // primary results symbol before mapSymbolAttributes is called.
+    Fortran::lower::SymbolBox resultArg;
+    if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
+            passedResult = callee.getPassedResult())
+      resultArg = lookupSymbol(passedResult->entity->get());
+
+    Fortran::lower::AggregateStoreMap storeMap;
+    // The front-end is currently not adding module variables referenced
+    // in a module procedure as host associated. As a result we need to
+    // instantiate all module variables here if this is a module procedure.
+    // It is likely that the front-end behavior should change here.
+    // This also applies to internal procedures inside module procedures.
+    if (auto *module = Fortran::lower::pft::getAncestor<
+            Fortran::lower::pft::ModuleLikeUnit>(funit))
+      for (const Fortran::lower::pft::Variable &var :
+           module->getOrderedSymbolTable())
+        instantiateVar(var, storeMap);
+
+    mlir::Value primaryFuncResultStorage;
+    for (const Fortran::lower::pft::Variable &var :
+         funit.getOrderedSymbolTable()) {
+      // Always instantiate aggregate storage blocks.
+      if (var.isAggregateStore()) {
+        instantiateVar(var, storeMap);
+        continue;
+      }
+      const Fortran::semantics::Symbol &sym = var.getSymbol();
+      if (funit.parentHasHostAssoc()) {
+        // Never instantitate host associated variables, as they are already
+        // instantiated from an argument tuple. Instead, just bind the symbol to
+        // the reference to the host variable, which must be in the map.
+        const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
+        if (funit.parentHostAssoc().isAssociated(ultimate)) {
+          Fortran::lower::SymbolBox hostBox =
+              localSymbols.lookupSymbol(ultimate);
+          assert(hostBox && "host association is not in map");
+          localSymbols.addSymbol(sym, hostBox.toExtendedValue());
+          continue;
+        }
+      }
+      if (!sym.IsFuncResult() || !funit.primaryResult) {
+        instantiateVar(var, storeMap);
+      } else if (&sym == funit.primaryResult) {
+        instantiateVar(var, storeMap);
+        primaryFuncResultStorage = getSymbolAddress(sym);
+      } else {
+        deferredFuncResultList.push_back(var);
+      }
+    }
+
+    // If this is a host procedure with host associations, then create the tuple
+    // of pointers for passing to the internal procedures.
+    if (!funit.getHostAssoc().empty())
+      funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);
+
+    /// TODO: should use same mechanism as equivalence?
+    /// One blocking point is character entry returns that need special handling
+    /// since they are not locally allocated but come as argument. CHARACTER(*)
+    /// is not something that fit wells with equivalence lowering.
+    for (const Fortran::lower::pft::Variable &altResult :
+         deferredFuncResultList) {
+      if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
+              passedResult = callee.getPassedResult())
+        addSymbol(altResult.getSymbol(), resultArg.getAddr());
+      Fortran::lower::StatementContext stmtCtx;
+      Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
+                                          stmtCtx, primaryFuncResultStorage);
+    }
+
+    // Create most function blocks in advance.
+    createEmptyBlocks(funit.evaluationList);
+
+    // Reinstate entry block as the current insertion point.
+    builder->setInsertionPointToEnd(&func.front());
+
+    if (callee.hasAlternateReturns()) {
+      // Create a local temp to hold the alternate return index.
+      // Give it an integer index type and the subroutine name (for dumps).
+      // Attach it to the subroutine symbol in the localSymbols map.
+      // Initialize it to zero, the "fallthrough" alternate return value.
+      const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();
+      mlir::Location loc = toLocation();
+      mlir::Type idxTy = builder->getIndexType();
+      mlir::Value altResult =
+          builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));
+      addSymbol(symbol, altResult);
+      mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
+      builder->create<fir::StoreOp>(loc, zero, altResult);
+    }
+
+    if (Fortran::lower::pft::Evaluation *alternateEntryEval =
+            funit.getEntryEval())
+      genFIRBranch(alternateEntryEval->lexicalSuccessor->block);
+  }
+
+  /// Create global blocks for the current function.  This eliminates the
+  /// distinction between forward and backward targets when generating
+  /// branches.  A block is "global" if it can be the target of a GOTO or
+  /// other source code branch.  A block that can only be targeted by a
+  /// compiler generated branch is "local".  For example, a DO loop preheader
+  /// block containing loop initialization code is global.  A loop header
+  /// block, which is the target of the loop back edge, is local.  Blocks
+  /// belong to a region.  Any block within a nested region must be replaced
+  /// with a block belonging to that region.  Branches may not cross region
+  /// boundaries.
+  void createEmptyBlocks(
+      std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
+    mlir::Region *region = &builder->getRegion();
+    for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
+      if (eval.isNewBlock)
+        eval.block = builder->createBlock(region);
+      if (eval.isConstruct() || eval.isDirective()) {
+        if (eval.lowerAsUnstructured()) {
+          createEmptyBlocks(eval.getNestedEvaluations());
+        } else if (eval.hasNestedEvaluations()) {
+          // A structured construct that is a target starts a new block.
+          Fortran::lower::pft::Evaluation &constructStmt =
+              eval.getFirstNestedEvaluation();
+          if (constructStmt.isNewBlock)
+            constructStmt.block = builder->createBlock(region);
+        }
+      }
+    }
+  }
+
+  /// Return the predicate: "current block does not have a terminator branch".
+  bool blockIsUnterminated() {
+    mlir::Block *currentBlock = builder->getBlock();
+    return currentBlock->empty() ||
+           !currentBlock->back().hasTrait<mlir::OpTrait::IsTerminator>();
+  }
+
+  /// Unconditionally switch code insertion to a new block.
+  void startBlock(mlir::Block *newBlock) {
+    assert(newBlock && "missing block");
+    // Default termination for the current block is a fallthrough branch to
+    // the new block.
+    if (blockIsUnterminated())
+      genFIRBranch(newBlock);
+    // Some blocks may be re/started more than once, and might not be empty.
+    // If the new block already has (only) a terminator, set the insertion
+    // point to the start of the block.  Otherwise set it to the end.
+    builder->setInsertionPointToStart(newBlock);
+    if (blockIsUnterminated())
+      builder->setInsertionPointToEnd(newBlock);
+  }
+
+  /// Conditionally switch code insertion to a new block.
+  void maybeStartBlock(mlir::Block *newBlock) {
+    if (newBlock)
+      startBlock(newBlock);
+  }
+
+  /// Emit return and cleanup after the function has been translated.
+  void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
+    setCurrentPosition(Fortran::lower::pft::stmtSourceLoc(funit.endStmt));
+    if (funit.isMainProgram())
+      genExitRoutine();
+    else
+      genFIRProcedureExit(funit, funit.getSubprogramSymbol());
+    funit.finalBlock = nullptr;
+    LLVM_DEBUG(llvm::dbgs() << "*** Lowering result:\n\n"
+                            << *builder->getFunction() << '\n');
+    // FIXME: Simplification should happen in a normal pass, not here.
+    mlir::IRRewriter rewriter(*builder);
+    (void)mlir::simplifyRegions(rewriter,
+                                {builder->getRegion()}); // remove dead code
+    delete builder;
+    builder = nullptr;
+    hostAssocTuple = mlir::Value{};
+    localSymbols.clear();
+  }
+
+  /// Helper to generate GlobalOps when the builder is not positioned in any
+  /// region block. This is required because the FirOpBuilder assumes it is
+  /// always positioned inside a region block when creating globals, the easiest
+  /// way comply is to create a dummy function and to throw it afterwards.
+  void createGlobalOutsideOfFunctionLowering(
+      const std::function<void()> &createGlobals) {
+    // FIXME: get rid of the bogus function context and instantiate the
+    // globals directly into the module.
+    mlir::MLIRContext *context = &getMLIRContext();
+    mlir::FuncOp func = fir::FirOpBuilder::createFunction(
+        mlir::UnknownLoc::get(context), getModuleOp(),
+        fir::NameUniquer::doGenerated("Sham"),
+        mlir::FunctionType::get(context, llvm::None, llvm::None));
+    func.addEntryBlock();
+    builder = new fir::FirOpBuilder(func, bridge.getKindMap());
+    createGlobals();
+    if (mlir::Region *region = func.getCallableRegion())
+      region->dropAllReferences();
+    func.erase();
+    delete builder;
+    builder = nullptr;
+    localSymbols.clear();
+  }
+  /// Instantiate the data from a BLOCK DATA unit.
+  void lowerBlockData(Fortran::lower::pft::BlockDataUnit &bdunit) {
+    createGlobalOutsideOfFunctionLowering([&]() {
+      Fortran::lower::AggregateStoreMap fakeMap;
+      for (const auto &[_, sym] : bdunit.symTab) {
+        if (sym->has<Fortran::semantics::ObjectEntityDetails>()) {
+          Fortran::lower::pft::Variable var(*sym, true);
+          instantiateVar(var, fakeMap);
+        }
+      }
+    });
+  }
+
+  /// Lower a procedure (nest).
+  void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
+    if (!funit.isMainProgram()) {
+      const Fortran::semantics::Symbol &procSymbol =
+          funit.getSubprogramSymbol();
+      if (procSymbol.owner().IsSubmodule()) {
+        TODO(toLocation(), "support submodules");
+        return;
+      }
+    }
+    setCurrentPosition(funit.getStartingSourceLoc());
+    for (int entryIndex = 0, last = funit.entryPointList.size();
+         entryIndex < last; ++entryIndex) {
+      funit.setActiveEntry(entryIndex);
+      startNewFunction(funit); // the entry point for lowering this procedure
+      for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)
+        genFIR(eval);
+      endNewFunction(funit);
+    }
+    funit.setActiveEntry(0);
+    for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
+      lowerFunc(f); // internal procedure
+  }
+
+  /// Lower module variable definitions to fir::globalOp and OpenMP/OpenACC
+  /// declarative construct.
+  void lowerModuleDeclScope(Fortran::lower::pft::ModuleLikeUnit &mod) {
+    setCurrentPosition(mod.getStartingSourceLoc());
+    createGlobalOutsideOfFunctionLowering([&]() {
+      for (const Fortran::lower::pft::Variable &var :
+           mod.getOrderedSymbolTable()) {
+        // Only define the variables owned by this module.
+        const Fortran::semantics::Scope *owningScope = var.getOwningScope();
+        if (!owningScope || mod.getScope() == *owningScope)
+          Fortran::lower::defineModuleVariable(*this, var);
+      }
+      for (auto &eval : mod.evaluationList)
+        genFIR(eval);
+    });
+  }
+
+  /// Lower functions contained in a module.
+  void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {
+    for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions)
+      lowerFunc(f);
+  }
+
+  void setCurrentPosition(const Fortran::parser::CharBlock &position) {
+    if (position != Fortran::parser::CharBlock{})
+      currentPosition = position;
+  }
+
+  /// Set current position at the location of \p parseTreeNode. Note that the
+  /// position is updated automatically when visiting statements, but not when
+  /// entering higher level nodes like constructs or procedures. This helper is
+  /// intended to cover the latter cases.
+  template <typename A>
+  void setCurrentPositionAt(const A &parseTreeNode) {
+    setCurrentPosition(Fortran::parser::FindSourceLocation(parseTreeNode));
+  }
+
+  //===--------------------------------------------------------------------===//
+  // Utility methods
+  //===--------------------------------------------------------------------===//
+
+  /// Convert a parser CharBlock to a Location
+  mlir::Location toLocation(const Fortran::parser::CharBlock &cb) {
+    return genLocation(cb);
+  }
+
+  mlir::Location toLocation() { return toLocation(currentPosition); }
+  void setCurrentEval(Fortran::lower::pft::Evaluation &eval) {
+    evalPtr = &eval;
+  }
+  Fortran::lower::pft::Evaluation &getEval() {
+    assert(evalPtr);
+    return *evalPtr;
+  }
+
+  std::optional<Fortran::evaluate::Shape>
+  getShape(const Fortran::lower::SomeExpr &expr) {
+    return Fortran::evaluate::GetShape(foldingContext, expr);
+  }
+
   //===--------------------------------------------------------------------===//
   // Analysis on a nested explicit iteration space.
   //===--------------------------------------------------------------------===//
 
   void analyzeExplicitSpace(const Fortran::parser::ConcurrentHeader &header) {
     explicitIterSpace.pushLevel();
     for (const Fortran::parser::ConcurrentControl &ctrl :
          std::get<std::list<Fortran::parser::ConcurrentControl>>(header.t)) {
void addMaskVariable(Fortran::lower::FrontEndExpr exp) {
     builder->create<fir::StoreOp>(loc, nullPtr2, shape);
     implicitIterSpace.addMaskVariable(exp, var, shape, hdr);
     explicitIterSpace.outermostContext().attachCleanup(
         [builder = this->builder, hdr, loc]() {
           fir::runtime::genRaggedArrayDeallocate(loc, *builder, hdr);
         });
   }
 
+  void createRuntimeTypeInfoGlobals() {}
+
   //===--------------------------------------------------------------------===//
 
   Fortran::lower::LoweringBridge &bridge;
   Fortran::evaluate::FoldingContext foldingContext;
   fir::FirOpBuilder *builder = nullptr;
   Fortran::lower::pft::Evaluation *evalPtr = nullptr;
   Fortran::lower::SymMap localSymbols;
   Fortran::parser::CharBlock currentPosition;
   RuntimeTypeInfoConverter runtimeTypeInfoConverter;
 
-  /// Tuple of host assoicated variables.
-  mlir::Value hostAssocTuple;
+  /// WHERE statement/construct mask expression stack.
   Fortran::lower::ImplicitIterSpace implicitIterSpace;
+
+  /// FORALL context
   Fortran::lower::ExplicitIterSpace explicitIterSpace;
+
+  /// Tuple of host assoicated variables.
+  mlir::Value hostAssocTuple;
+
+  std::size_t constructDepth = 0;
 };
 
 } // namespace
 
 Fortran::evaluate::FoldingContext
 Fortran::lower::LoweringBridge::createFoldingContext() const {
   return {getDefaultKinds(), getIntrinsicTable()};
 }
 
 void Fortran::lower::LoweringBridge::lower(
     const Fortran::parser::Program &prg,
     const Fortran::semantics::SemanticsContext &semanticsContext) {
   std::unique_ptr<Fortran::lower::pft::Program> pft =
       Fortran::lower::createPFT(prg, semanticsContext);
   if (dumpBeforeFir)
     Fortran::lower::dumpPFT(llvm::errs(), *pft);
   FirConverter converter{*this};
   converter.run(*pft);
 }
 
+void Fortran::lower::LoweringBridge::parseSourceFile(llvm::SourceMgr &srcMgr) {
+  mlir::OwningOpRef<mlir::ModuleOp> owningRef =
+      mlir::parseSourceFile<mlir::ModuleOp>(srcMgr, &context);
+  module.reset(new mlir::ModuleOp(owningRef.get().getOperation()));
+  owningRef.release();
+}
+
 Fortran::lower::LoweringBridge::LoweringBridge(
     mlir::MLIRContext &context,
     const Fortran::common::IntrinsicTypeDefaultKinds &defaultKinds,
     const Fortran::evaluate::IntrinsicProcTable &intrinsics,
     const Fortran::parser::AllCookedSources &cooked, llvm::StringRef triple,
     fir::KindMapping &kindMap)
     : defaultKinds{defaultKinds}, intrinsics{intrinsics}, cooked{&cooked},
       context{context}, kindMap{kindMap} {
   // Register the diagnostic handler.
   context.getDiagEngine().registerHandler([](mlir::Diagnostic &diag) {
     llvm::raw_ostream &os = llvm::errs();
     switch (diag.getSeverity()) {
     case mlir::DiagnosticSeverity::Error:
       os << "error: ";
       break;
     case mlir::DiagnosticSeverity::Remark:
       os << "info: ";
       break;
     case mlir::DiagnosticSeverity::Warning:
       os << "warning: ";
       break;
     default:
       break;
     }
-    if (!diag.getLocation().isa<UnknownLoc>())
+    if (!diag.getLocation().isa<mlir::UnknownLoc>())
       os << diag.getLocation() << ": ";
     os << diag << '\n';
     os.flush();
     return mlir::success();
   });
 
   // Create the module and attach the attributes.
   module = std::make_unique<mlir::ModuleOp>(
       mlir::ModuleOp::create(mlir::UnknownLoc::get(&context)));
   assert(module.get() && "module was not created");
-  fir::setTargetTriple(getModule(), triple);
-  fir::setKindMapping(getModule(), kindMap);
+  fir::setTargetTriple(*module.get(), triple);
+  fir::setKindMapping(*module.get(), kindMap);
 }

flang/lib/Lower/CallInterface.cpp

getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) {
   return Fortran::common::Clone(*ubound) - Fortran::common::Clone(*lbound) +
          Fortran::evaluate::ExtentExpr{1};
 }
 
 void Fortran::lower::CallerInterface::walkResultExtents(
     ExprVisitor visitor) const {
   // Walk directly the result symbol shape (the characteristic shape may contain
   // descriptor inquiries to it that would fail to lower on the caller side).
-  const Fortran::semantics::Symbol *interfaceSymbol =
-      procRef.proc().GetInterfaceSymbol();
-  if (interfaceSymbol) {
-    const Fortran::semantics::Symbol &result =
-        interfaceSymbol->get<Fortran::semantics::SubprogramDetails>().result();
+  const Fortran::semantics::SubprogramDetails *interfaceDetails =
+      getInterfaceDetails();
+  if (interfaceDetails) {
+    const Fortran::semantics::Symbol &result = interfaceDetails->result();
     if (const auto *objectDetails =
             result.detailsIf<Fortran::semantics::ObjectEntityDetails>())
       if (objectDetails->shape().IsExplicitShape())
         for (const Fortran::semantics::ShapeSpec &shapeSpec :
              objectDetails->shape())
           visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec)));
   } else {
     if (procRef.Rank() != 0)
       fir::emitFatalError(
           converter.getCurrentLocation(),
           "only scalar functions may not have an interface symbol");
   }
 }
 
 bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
   assert(characteristic && "characteristic was not computed");
   const std::optional<Fortran::evaluate::characteristics::FunctionResult>
       &result = characteristic->functionResult;
   if (!result || result->CanBeReturnedViaImplicitInterface() ||
-      !procRef.proc().GetInterfaceSymbol())
+      !getInterfaceDetails())
     return false;
   bool allResultSpecExprConstant = true;
   auto visitor = [&](const Fortran::lower::SomeExpr &e) {
     allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e);
   };
   walkResultLengths(visitor);
   walkResultExtents(visitor);
   return !allResultSpecExprConstant;
 }
 
 mlir::Value Fortran::lower::CallerInterface::getArgumentValue(
     const semantics::Symbol &sym) const {
   mlir::Location loc = converter.getCurrentLocation();
-  const Fortran::semantics::Symbol *iface = procRef.proc().GetInterfaceSymbol();
-  if (!iface)
+  const Fortran::semantics::SubprogramDetails *ifaceDetails =
+      getInterfaceDetails();
+  if (!ifaceDetails)
     fir::emitFatalError(
         loc, "mapping actual and dummy arguments requires an interface");
   const std::vector<Fortran::semantics::Symbol *> &dummies =
-      iface->get<semantics::SubprogramDetails>().dummyArgs();
+      ifaceDetails->dummyArgs();
   auto it = std::find(dummies.begin(), dummies.end(), &sym);
   if (it == dummies.end())
     fir::emitFatalError(loc, "symbol is not a dummy in this call");
   FirValue mlirArgIndex = passedArguments[it - dummies.begin()].firArgument;
   return actualInputs[mlirArgIndex];
 }
 
 mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const {
   if (passedResult)
     return fir::dyn_cast_ptrEleTy(inputs[passedResult->firArgument].type);
   assert(saveResult && !outputs.empty());
   return outputs[0].type;
 }
 
 const Fortran::semantics::Symbol &
 Fortran::lower::CallerInterface::getResultSymbol() const {
   mlir::Location loc = converter.getCurrentLocation();
-  const Fortran::semantics::Symbol *iface = procRef.proc().GetInterfaceSymbol();
-  if (!iface)
+  const Fortran::semantics::SubprogramDetails *ifaceDetails =
+      getInterfaceDetails();
+  if (!ifaceDetails)
     fir::emitFatalError(
         loc, "mapping actual and dummy arguments requires an interface");
-  return iface->get<semantics::SubprogramDetails>().result();
+  return ifaceDetails->result();
+}
+
+const Fortran::semantics::SubprogramDetails *
+Fortran::lower::CallerInterface::getInterfaceDetails() const {
+  if (const Fortran::semantics::Symbol *iface =
+          procRef.proc().GetInterfaceSymbol())
+    return iface->GetUltimate()
+        .detailsIf<Fortran::semantics::SubprogramDetails>();
+  return nullptr;
 }
 
 //===----------------------------------------------------------------------===//
 // Callee side interface implementation
 //===----------------------------------------------------------------------===//
 
 bool Fortran::lower::CalleeInterface::hasAlternateReturns() const {
   return !funit.isMainProgram() &&

flang/lib/Lower/ConvertExpr.cpp

 //===-- ConvertExpr.cpp ---------------------------------------------------===//
 //
 // 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/ConvertExpr.h"
+#include "flang/Common/default-kinds.h"
+#include "flang/Common/unwrap.h"
 #include "flang/Evaluate/fold.h"
+#include "flang/Evaluate/real.h"
 #include "flang/Evaluate/traverse.h"
-#include "flang/Lower/AbstractConverter.h"
 #include "flang/Lower/Allocatable.h"
+#include "flang/Lower/Bridge.h"
 #include "flang/Lower/BuiltinModules.h"
 #include "flang/Lower/CallInterface.h"
+#include "flang/Lower/Coarray.h"
 #include "flang/Lower/ComponentPath.h"
 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/CustomIntrinsicCall.h"
 #include "flang/Lower/DumpEvaluateExpr.h"
 #include "flang/Lower/IntrinsicCall.h"
 #include "flang/Lower/Mangler.h"
-#include "flang/Lower/StatementContext.h"
-#include "flang/Lower/SymbolMap.h"
+#include "flang/Lower/Runtime.h"
+#include "flang/Lower/Support/Utils.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/Factory.h"
-#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
-#include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Builder/Runtime/Character.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/Ragged.h"
+#include "flang/Optimizer/Dialect/FIRAttr.h"
+#include "flang/Optimizer/Dialect/FIRDialect.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
-#include "flang/Optimizer/Support/Matcher.h"
+#include "flang/Optimizer/Support/FatalError.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "flang/Semantics/type.h"
 #include "mlir/Dialect/Func/IR/FuncOps.h"
 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/Debug.h"
+#include "llvm/Support/ErrorHandling.h"
+#include "llvm/Support/raw_ostream.h"
+#include <algorithm>
 
 #define DEBUG_TYPE "flang-lower-expr"
 
 //===----------------------------------------------------------------------===//
 // The composition and structure of Fortran::evaluate::Expr is defined in
 // the various header files in include/flang/Evaluate. You are referred
 // there for more information on these data structures. Generally speaking,
 // these data structures are a strongly typed family of abstract data types
public:
   /// Generate a real constant with a value `value`.
   template <int KIND>
   mlir::Value genRealConstant(mlir::MLIRContext *context,
                               const llvm::APFloat &value) {
     mlir::Type fltTy = Fortran::lower::convertReal(context, KIND);
     return builder.createRealConstant(getLoc(), fltTy, value);
   }
 
+  mlir::Type getSomeKindInteger() { return builder.getIndexType(); }
+
+  mlir::FuncOp getFunction(llvm::StringRef name, mlir::FunctionType funTy) {
+    if (mlir::FuncOp func = builder.getNamedFunction(name))
+      return func;
+    return builder.createFunction(getLoc(), name, funTy);
+  }
+
   template <typename OpTy>
   mlir::Value createCompareOp(mlir::arith::CmpIPredicate pred,
                               const ExtValue &left, const ExtValue &right) {
     if (const fir::UnboxedValue *lhs = left.getUnboxed())
       if (const fir::UnboxedValue *rhs = right.getUnboxed())
         return builder.create<OpTy>(getLoc(), pred, *lhs, *rhs);
     fir::emitFatalError(getLoc(), "array compare should be handled in genarr");
   }
if (const fir::UnboxedValue *s = var.getUnboxed())
                                          addr);
         }
         return genLoad(addr);
       }
     return var;
   }
 
   ExtValue genval(const Fortran::evaluate::BOZLiteralConstant &) {
-    TODO(getLoc(), "genval BOZ");
+    TODO(getLoc(), "BOZ");
   }
 
   /// Return indirection to function designated in ProcedureDesignator.
   /// The type of the function indirection is not guaranteed to match the one
   /// of the ProcedureDesignator due to Fortran implicit typing rules.
   ExtValue genval(const Fortran::evaluate::ProcedureDesignator &proc) {
     mlir::Location loc = getLoc();
     if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) {
     case Fortran::evaluate::DescriptorInquiry::Field::Stride:
       // So far the front end does not generate this inquiry.
       TODO(loc, "Stride inquiry");
     }
     llvm_unreachable("unknown descriptor inquiry");
   }
 
   ExtValue genval(const Fortran::evaluate::TypeParamInquiry &) {
-    TODO(getLoc(), "genval TypeParamInquiry");
+    TODO(getLoc(), "type parameter inquiry");
+  }
+
+  mlir::Value extractComplexPart(mlir::Value cplx, bool isImagPart) {
+    return fir::factory::Complex{builder, getLoc()}.extractComplexPart(
+        cplx, isImagPart);
   }
 
   template <int KIND>
   ExtValue genval(const Fortran::evaluate::ComplexComponent<KIND> &part) {
-    TODO(getLoc(), "genval ComplexComponent");
+    return extractComplexPart(genunbox(part.left()), part.isImaginaryPart);
   }
 
   template <int KIND>
   ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
                       Fortran::common::TypeCategory::Integer, KIND>> &op) {
     mlir::Value input = genunbox(op.left());
     // Like LLVM, integer negation is the binary op "0 - value"
     mlir::Value zero = genIntegerConstant<KIND>(builder.getContext(), 0);
     return builder.create<mlir::arith::SubIOp>(getLoc(), zero, input);
   }
-
   template <int KIND>
   ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
                       Fortran::common::TypeCategory::Real, KIND>> &op) {
     return builder.create<mlir::arith::NegFOp>(getLoc(), genunbox(op.left()));
   }
   template <int KIND>
   ExtValue genval(const Fortran::evaluate::Negate<Fortran::evaluate::Type<
                       Fortran::common::TypeCategory::Complex, KIND>> &op) {
ExtValue genval(const Fortran::evaluate::Concat<KIND> &op) {
     TODO(getLoc(), "character array concatenate");
   }
 
   /// MIN and MAX operations
   template <Fortran::common::TypeCategory TC, int KIND>
   ExtValue
   genval(const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>>
              &op) {
-    TODO(getLoc(), "genval Extremum<TC, KIND>");
+    mlir::Value lhs = genunbox(op.left());
+    mlir::Value rhs = genunbox(op.right());
+    switch (op.ordering) {
+    case Fortran::evaluate::Ordering::Greater:
+      return Fortran::lower::genMax(builder, getLoc(),
+                                    llvm::ArrayRef<mlir::Value>{lhs, rhs});
+    case Fortran::evaluate::Ordering::Less:
+      return Fortran::lower::genMin(builder, getLoc(),
+                                    llvm::ArrayRef<mlir::Value>{lhs, rhs});
+    case Fortran::evaluate::Ordering::Equal:
+      llvm_unreachable("Equal is not a valid ordering in this context");
+    }
+    llvm_unreachable("unknown ordering");
   }
 
   // Change the dynamic length information without actually changing the
   // underlying character storage.
   fir::ExtendedValue
   replaceScalarCharacterLength(const fir::ExtendedValue &scalarChar,
                                mlir::Value newLenValue) {
     mlir::Location loc = getLoc();
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
   ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
                       Fortran::common::TypeCategory::Real, KIND>> &op) {
     return createFltCmpOp<mlir::arith::CmpFOp>(
         op, translateFloatRelational(op.opr));
   }
   template <int KIND>
   ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
                       Fortran::common::TypeCategory::Complex, KIND>> &op) {
-    TODO(getLoc(), "genval complex comparison");
+    return createFltCmpOp<fir::CmpcOp>(op, translateFloatRelational(op.opr));
   }
   template <int KIND>
   ExtValue genval(const Fortran::evaluate::Relational<Fortran::evaluate::Type<
                       Fortran::common::TypeCategory::Character, KIND>> &op) {
     return createCharCompare(op, translateRelational(op.opr));
   }
 
   ExtValue
   genval(const Fortran::evaluate::Relational<Fortran::evaluate::SomeType> &op) {
     return std::visit([&](const auto &x) { return genval(x); }, op.u);
   }
 
   template <Fortran::common::TypeCategory TC1, int KIND,
             Fortran::common::TypeCategory TC2>
   ExtValue
   genval(const Fortran::evaluate::Convert<Fortran::evaluate::Type<TC1, KIND>,
                                           TC2> &convert) {
     mlir::Type ty = converter.genType(TC1, KIND);
-    mlir::Value operand = genunbox(convert.left());
-    return builder.convertWithSemantics(getLoc(), ty, operand);
+    auto fromExpr = genval(convert.left());
+    auto loc = getLoc();
+    return fromExpr.match(
+        [&](const fir::CharBoxValue &boxchar) -> ExtValue {
+          if constexpr (TC1 == Fortran::common::TypeCategory::Character &&
+                        TC2 == TC1) {
+            // Use char_convert. Each code point is translated from a
+            // narrower/wider encoding to the target encoding. For example, 'A'
+            // may be translated from 0x41 : i8 to 0x0041 : i16. The symbol
+            // for euro (0x20AC : i16) may be translated from a wide character
+            // to "0xE2 0x82 0xAC" : UTF-8.
+            mlir::Value bufferSize = boxchar.getLen();
+            auto kindMap = builder.getKindMap();
+            auto fromBits = kindMap.getCharacterBitsize(
+                fir::unwrapRefType(boxchar.getAddr().getType())
+                    .cast<fir::CharacterType>()
+                    .getFKind());
+            auto toBits = kindMap.getCharacterBitsize(
+                ty.cast<fir::CharacterType>().getFKind());
+            if (toBits < fromBits) {
+              // Scale by relative ratio to give a buffer of the same length.
+              auto ratio = builder.createIntegerConstant(
+                  loc, bufferSize.getType(), fromBits / toBits);
+              bufferSize =
+                  builder.create<mlir::arith::MulIOp>(loc, bufferSize, ratio);
+            }
+            auto dest = builder.create<fir::AllocaOp>(
+                loc, ty, mlir::ValueRange{bufferSize});
+            builder.create<fir::CharConvertOp>(loc, boxchar.getAddr(),
+                                               boxchar.getLen(), dest);
+            return fir::CharBoxValue{dest, boxchar.getLen()};
+          } else {
+            fir::emitFatalError(
+                loc, "unsupported evaluate::Convert between CHARACTER type "
+                     "category and non-CHARACTER category");
+          }
+        },
+        [&](const fir::UnboxedValue &value) -> ExtValue {
+          return builder.convertWithSemantics(loc, ty, value);
+        },
+        [&](auto &) -> ExtValue {
+          fir::emitFatalError(loc, "unsupported evaluate::Convert");
+        });
   }
 
   template <typename A>
   ExtValue genval(const Fortran::evaluate::Parentheses<A> &op) {
-    TODO(getLoc(), "genval parentheses<A>");
+    ExtValue input = genval(op.left());
+    mlir::Value base = fir::getBase(input);
+    mlir::Value newBase =
+        builder.create<fir::NoReassocOp>(getLoc(), base.getType(), base);
+    return fir::substBase(input, newBase);
   }
 
   template <int KIND>
   ExtValue genval(const Fortran::evaluate::Not<KIND> &op) {
     mlir::Value logical = genunbox(op.left());
     mlir::Value one = genBoolConstant(true);
     mlir::Value val =
         builder.createConvert(getLoc(), builder.getI1Type(), logical);
std::optional<Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC, KIND>>>
         opt = con.GetScalarValue();
     assert(opt.has_value() && "constant has no value");
     if constexpr (TC == Fortran::common::TypeCategory::Character) {
       return genScalarLit<KIND>(opt.value(), con.LEN());
     } else {
       return genScalarLit<TC, KIND>(opt.value());
     }
   }
-
   fir::ExtendedValue genval(
       const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) {
     if (con.Rank() > 0)
       return genArrayLit(con);
     if (auto ctor = con.GetScalarValue())
       return genval(ctor.value());
     fir::emitFatalError(getLoc(),
                         "constant of derived type has no constructor");
   }
 
   template <typename A>
   ExtValue genval(const Fortran::evaluate::ArrayConstructor<A> &) {
-    TODO(getLoc(), "genval ArrayConstructor<A>");
+    fir::emitFatalError(getLoc(),
+                        "array constructor: lowering should not reach here");
   }
 
   ExtValue gen(const Fortran::evaluate::ComplexPart &x) {
-    TODO(getLoc(), "gen ComplexPart");
+    mlir::Location loc = getLoc();
+    auto idxTy = builder.getI32Type();
+    ExtValue exv = gen(x.complex());
+    mlir::Value base = fir::getBase(exv);
+    fir::factory::Complex helper{builder, loc};
+    mlir::Type eleTy =
+        helper.getComplexPartType(fir::dyn_cast_ptrEleTy(base.getType()));
+    mlir::Value offset = builder.createIntegerConstant(
+        loc, idxTy,
+        x.part() == Fortran::evaluate::ComplexPart::Part::RE ? 0 : 1);
+    mlir::Value result = builder.create<fir::CoordinateOp>(
+        loc, builder.getRefType(eleTy), base, mlir::ValueRange{offset});
+    return {result};
   }
   ExtValue genval(const Fortran::evaluate::ComplexPart &x) {
-    TODO(getLoc(), "genval ComplexPart");
+    return genLoad(gen(x));
   }
 
   /// Reference to a substring.
   ExtValue gen(const Fortran::evaluate::Substring &s) {
     // Get base string
     auto baseString = std::visit(
         Fortran::common::visitors{
             [&](const Fortran::evaluate::DataRef &x) { return gen(x); },
ExtValue genval(const Fortran::evaluate::Subscript &subs) {
     if (auto *s = std::get_if<Fortran::evaluate::IndirectSubscriptIntegerExpr>(
             &subs.u)) {
       if (s->value().Rank() > 0)
         fir::emitFatalError(getLoc(), "vector subscript is not scalar");
       return {genval(s->value())};
     }
     fir::emitFatalError(getLoc(), "subscript triple notation is not scalar");
   }
-
   ExtValue genSubscript(const Fortran::evaluate::Subscript &subs) {
     return genval(subs);
   }
 
   ExtValue gen(const Fortran::evaluate::DataRef &dref) {
     return std::visit([&](const auto &x) { return gen(x); }, dref.u);
   }
   ExtValue genval(const Fortran::evaluate::DataRef &dref) {
     return std::visit([&](const auto &x) { return genval(x); }, dref.u);
   }
 
   // Helper function to turn the Component structure into a list of nested
   // components, ordered from largest/leftmost to smallest/rightmost:
   //  - where only the smallest/rightmost item may be allocatable or a pointer
   //    (nested allocatable/pointer components require nested coordinate_of ops)
   //  - that does not contain any parent components
   //    (the front end places parent components directly in the object)
   // Return the object used as the base coordinate for the component chain.
   static Fortran::evaluate::DataRef const *
   reverseComponents(const Fortran::evaluate::Component &cmpt,
                     std::list<const Fortran::evaluate::Component *> &list) {
-    if (!cmpt.GetLastSymbol().test(
-            Fortran::semantics::Symbol::Flag::ParentComp))
+    if (!getLastSym(cmpt).test(Fortran::semantics::Symbol::Flag::ParentComp))
       list.push_front(&cmpt);
     return std::visit(
         Fortran::common::visitors{
             [&](const Fortran::evaluate::Component &x) {
-              if (Fortran::semantics::IsAllocatableOrPointer(x.GetLastSymbol()))
+              if (Fortran::semantics::IsAllocatableOrPointer(getLastSym(x)))
                 return &cmpt.base();
               return reverseComponents(x, list);
             },
             [&](auto &) { return &cmpt.base(); },
         },
         cmpt.base().u);
   }
 
   // Return the coordinate of the component reference
   ExtValue genComponent(const Fortran::evaluate::Component &cmpt) {
     std::list<const Fortran::evaluate::Component *> list;
     const Fortran::evaluate::DataRef *base = reverseComponents(cmpt, list);
     llvm::SmallVector<mlir::Value> coorArgs;
     ExtValue obj = gen(*base);
     mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(obj).getType());
     mlir::Location loc = getLoc();
     auto fldTy = fir::FieldType::get(&converter.getMLIRContext());
     // FIXME: need to thread the LEN type parameters here.
     for (const Fortran::evaluate::Component *field : list) {
       auto recTy = ty.cast<fir::RecordType>();
-      const Fortran::semantics::Symbol &sym = field->GetLastSymbol();
+      const Fortran::semantics::Symbol &sym = getLastSym(*field);
       llvm::StringRef name = toStringRef(sym.name());
       coorArgs.push_back(builder.create<fir::FieldIndexOp>(
           loc, fldTy, name, recTy, fir::getTypeParams(obj)));
       ty = recTy.getType(name);
     }
     ty = builder.getRefType(ty);
     return fir::factory::componentToExtendedValue(
         builder, loc,
return genComponent(cmpt).match(
         },
         [](auto &box) -> ExtValue { return box; });
   }
 
   ExtValue genval(const Fortran::evaluate::Component &cmpt) {
     return genLoad(gen(cmpt));
   }
 
-  ExtValue genval(const Fortran::semantics::Bound &bound) {
-    TODO(getLoc(), "genval Bound");
+  // Determine the result type after removing `dims` dimensions from the array
+  // type `arrTy`
+  mlir::Type genSubType(mlir::Type arrTy, unsigned dims) {
+    mlir::Type unwrapTy = fir::dyn_cast_ptrOrBoxEleTy(arrTy);
+    assert(unwrapTy && "must be a pointer or box type");
+    auto seqTy = unwrapTy.cast<fir::SequenceType>();
+    llvm::ArrayRef<int64_t> shape = seqTy.getShape();
+    assert(shape.size() > 0 && "removing columns for sequence sans shape");
+    assert(dims <= shape.size() && "removing more columns than exist");
+    fir::SequenceType::Shape newBnds;
+    // follow Fortran semantics and remove columns (from right)
+    std::size_t e = shape.size() - dims;
+    for (decltype(e) i = 0; i < e; ++i)
+      newBnds.push_back(shape[i]);
+    if (!newBnds.empty())
+      return fir::SequenceType::get(newBnds, seqTy.getEleTy());
+    return seqTy.getEleTy();
   }
 
-  /// Return lower bounds of \p box in dimension \p dim. The returned value
-  /// has type \ty.
-  mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) {
-    assert(box.rank() > 0 && "must be an array");
-    mlir::Location loc = getLoc();
-    mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
-    mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one);
-    return builder.createConvert(loc, ty, lb);
+  // Generate the code for a Bound value.
+  ExtValue genval(const Fortran::semantics::Bound &bound) {
+    if (bound.isExplicit()) {
+      Fortran::semantics::MaybeSubscriptIntExpr sub = bound.GetExplicit();
+      if (sub.has_value())
+        return genval(*sub);
+      return genIntegerConstant<8>(builder.getContext(), 1);
+    }
+    TODO(getLoc(), "non explicit semantics::Bound lowering");
   }
 
   static bool isSlice(const Fortran::evaluate::ArrayRef &aref) {
     for (const Fortran::evaluate::Subscript &sub : aref.subscript())
       if (std::holds_alternative<Fortran::evaluate::Triplet>(sub.u))
         return true;
     return false;
   }
ExtValue base = aref.base().IsSymbol() ? gen(getFirstSym(aref.base()))
                                            : gen(aref.base().GetComponent());
     // Check for command-line override to use array_coor op.
     if (generateArrayCoordinate)
       return genArrayCoorOp(base, aref);
     // Otherwise, use coordinate_of op.
     return genCoordinateOp(base, aref);
   }
 
+  /// Return lower bounds of \p box in dimension \p dim. The returned value
+  /// has type \ty.
+  mlir::Value getLBound(const ExtValue &box, unsigned dim, mlir::Type ty) {
+    assert(box.rank() > 0 && "must be an array");
+    mlir::Location loc = getLoc();
+    mlir::Value one = builder.createIntegerConstant(loc, ty, 1);
+    mlir::Value lb = fir::factory::readLowerBound(builder, loc, box, dim, one);
+    return builder.createConvert(loc, ty, lb);
+  }
+
   ExtValue genval(const Fortran::evaluate::ArrayRef &aref) {
     return genLoad(gen(aref));
   }
 
   ExtValue gen(const Fortran::evaluate::CoarrayRef &coref) {
-    TODO(getLoc(), "gen CoarrayRef");
+    return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap}
+        .genAddr(coref);
   }
+
   ExtValue genval(const Fortran::evaluate::CoarrayRef &coref) {
-    TODO(getLoc(), "genval CoarrayRef");
+    return Fortran::lower::CoarrayExprHelper{converter, getLoc(), symMap}
+        .genValue(coref);
   }
 
   template <typename A>
   ExtValue gen(const Fortran::evaluate::Designator<A> &des) {
     return std::visit([&](const auto &x) { return gen(x); }, des.u);
   }
   template <typename A>
   ExtValue genval(const Fortran::evaluate::Designator<A> &des) {
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
   /// value. This is required for lowering expressions such as `f1(f2(v))`.
   template <typename A>
   ExtValue gen(const Fortran::evaluate::FunctionRef<A> &funcRef) {
     ExtValue retVal = genFunctionRef(funcRef);
     mlir::Type resultType = converter.genType(toEvExpr(funcRef));
     return placeScalarValueInMemory(builder, getLoc(), retVal, resultType);
   }
 
+  /// Helper to lower intrinsic arguments for inquiry intrinsic.
+  ExtValue
+  lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) {
+    if (Fortran::evaluate::IsAllocatableOrPointerObject(
+            expr, converter.getFoldingContext()))
+      return genMutableBoxValue(expr);
+    /// Do not create temps for array sections whose properties only need to be
+    /// inquired: create a descriptor that will be inquired.
+    if (Fortran::evaluate::IsVariable(expr) && isArray(expr) &&
+        !Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr))
+      return lowerIntrinsicArgumentAsBox(expr);
+    return gen(expr);
+  }
+
+  /// Helper to lower intrinsic arguments to a fir::BoxValue.
+  /// It preserves all the non default lower bounds/non deferred length
+  /// parameter information.
+  ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) {
+    mlir::Location loc = getLoc();
+    ExtValue exv = genBoxArg(expr);
+    mlir::Value box = builder.createBox(loc, exv);
+    return fir::BoxValue(
+        box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv),
+        fir::factory::getNonDeferredLengthParams(exv));
+  }
+
+  /// Generate a call to an intrinsic function.
+  ExtValue
+  genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef,
+                  const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+                  llvm::Optional<mlir::Type> resultType) {
+    llvm::SmallVector<ExtValue> operands;
+
+    llvm::StringRef name = intrinsic.name;
+    mlir::Location loc = getLoc();
+    if (Fortran::lower::intrinsicRequiresCustomOptionalHandling(
+            procRef, intrinsic, converter)) {
+      using ExvAndPresence = std::pair<ExtValue, llvm::Optional<mlir::Value>>;
+      llvm::SmallVector<ExvAndPresence, 4> operands;
+      auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
+        ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr);
+        mlir::Value isPresent =
+            genActualIsPresentTest(builder, loc, optionalArg);
+        operands.emplace_back(optionalArg, isPresent);
+      };
+      auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) {
+        operands.emplace_back(genval(expr), llvm::None);
+      };
+      Fortran::lower::prepareCustomIntrinsicArgument(
+          procRef, intrinsic, resultType, prepareOptionalArg, prepareOtherArg,
+          converter);
+
+      auto getArgument = [&](std::size_t i) -> ExtValue {
+        if (fir::conformsWithPassByRef(
+                fir::getBase(operands[i].first).getType()))
+          return genLoad(operands[i].first);
+        return operands[i].first;
+      };
+      auto isPresent = [&](std::size_t i) -> llvm::Optional<mlir::Value> {
+        return operands[i].second;
+      };
+      return Fortran::lower::lowerCustomIntrinsic(
+          builder, loc, name, resultType, isPresent, getArgument,
+          operands.size(), stmtCtx);
+    }
+
+    const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering =
+        Fortran::lower::getIntrinsicArgumentLowering(name);
+    for (const auto &[arg, dummy] :
+         llvm::zip(procRef.arguments(),
+                   intrinsic.characteristics.value().dummyArguments)) {
+      auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg);
+      if (!expr) {
+        // Absent optional.
+        operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument());
+        continue;
+      }
+      if (!argLowering) {
+        // No argument lowering instruction, lower by value.
+        operands.emplace_back(genval(*expr));
+        continue;
+      }
+      // Ad-hoc argument lowering handling.
+      Fortran::lower::ArgLoweringRule argRules =
+          Fortran::lower::lowerIntrinsicArgumentAs(loc, *argLowering,
+                                                   dummy.name);
+      if (argRules.handleDynamicOptional &&
+          Fortran::evaluate::MayBePassedAsAbsentOptional(
+              *expr, converter.getFoldingContext())) {
+        ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr);
+        mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional);
+        switch (argRules.lowerAs) {
+        case Fortran::lower::LowerIntrinsicArgAs::Value:
+          operands.emplace_back(
+              genOptionalValue(builder, loc, optional, isPresent));
+          continue;
+        case Fortran::lower::LowerIntrinsicArgAs::Addr:
+          operands.emplace_back(
+              genOptionalAddr(builder, loc, optional, isPresent));
+          continue;
+        case Fortran::lower::LowerIntrinsicArgAs::Box:
+          operands.emplace_back(
+              genOptionalBox(builder, loc, optional, isPresent));
+          continue;
+        case Fortran::lower::LowerIntrinsicArgAs::Inquired:
+          operands.emplace_back(optional);
+          continue;
+        }
+        llvm_unreachable("bad switch");
+      }
+      switch (argRules.lowerAs) {
+      case Fortran::lower::LowerIntrinsicArgAs::Value:
+        operands.emplace_back(genval(*expr));
+        continue;
+      case Fortran::lower::LowerIntrinsicArgAs::Addr:
+        operands.emplace_back(gen(*expr));
+        continue;
+      case Fortran::lower::LowerIntrinsicArgAs::Box:
+        operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr));
+        continue;
+      case Fortran::lower::LowerIntrinsicArgAs::Inquired:
+        operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr));
+        continue;
+      }
+      llvm_unreachable("bad switch");
+    }
+    // Let the intrinsic library lower the intrinsic procedure call
+    return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType,
+                                            operands, stmtCtx);
+  }
+
+  template <typename A>
+  bool isCharacterType(const A &exp) {
+    if (auto type = exp.GetType())
+      return type->category() == Fortran::common::TypeCategory::Character;
+    return false;
+  }
+
   /// helper to detect statement functions
   static bool
   isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) {
     if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
       if (const auto *details =
               symbol->detailsIf<Fortran::semantics::SubprogramDetails>())
         return details->stmtFunction().has_value();
     return false;
ExtValue genTempExtAddr(const Fortran::lower::SomeExpr &expr) {
     // parentheses to avoid creating array temporary in sub-expressions. It only
     // ensures the sub-expression is not re-associated with other parts of the
     // expression. In the call semantics, there is a difference between expr and
     // variable (see R1524). For expressions, a variable storage must not be
     // argument associated since it could be modified inside the call, or the
     // variable could also be modified by other means during the call.
     if (!isParenthesizedVariable(expr))
       return genExtAddr(expr);
-    mlir::Location loc = getLoc();
     if (expr.Rank() > 0)
-      TODO(loc, "genTempExtAddr array");
+      return asArray(expr);
+    mlir::Location loc = getLoc();
     return genExtValue(expr).match(
         [&](const fir::CharBoxValue &boxChar) -> ExtValue {
-          TODO(loc, "genTempExtAddr CharBoxValue");
+          return fir::factory::CharacterExprHelper{builder, loc}.createTempFrom(
+              boxChar);
         },
         [&](const fir::UnboxedValue &v) -> ExtValue {
           mlir::Type type = v.getType();
           mlir::Value value = v;
           if (fir::isa_ref_type(type))
             value = builder.create<fir::LoadOp>(loc, value);
           mlir::Value temp = builder.createTemporary(loc, value.getType());
           builder.create<fir::StoreOp>(loc, value, temp);

 
   ExtValue genval(const Fortran::evaluate::ProcedureRef &procRef) {
     llvm::Optional<mlir::Type> resTy;
     if (procRef.hasAlternateReturns())
       resTy = builder.getIndexType();
     return genProcedureRef(procRef, resTy);
   }
 
-  /// Helper to lower intrinsic arguments for inquiry intrinsic.
-  ExtValue
-  lowerIntrinsicArgumentAsInquired(const Fortran::lower::SomeExpr &expr) {
-    if (Fortran::evaluate::IsAllocatableOrPointerObject(
-            expr, converter.getFoldingContext()))
-      return genMutableBoxValue(expr);
-    return gen(expr);
-  }
-
-  /// Helper to lower intrinsic arguments to a fir::BoxValue.
-  /// It preserves all the non default lower bounds/non deferred length
-  /// parameter information.
-  ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) {
-    mlir::Location loc = getLoc();
-    ExtValue exv = genBoxArg(expr);
-    mlir::Value box = builder.createBox(loc, exv);
-    return fir::BoxValue(
-        box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv),
-        fir::factory::getNonDeferredLengthParams(exv));
-  }
-
-  /// Generate a call to an intrinsic function.
-  ExtValue
-  genIntrinsicRef(const Fortran::evaluate::ProcedureRef &procRef,
-                  const Fortran::evaluate::SpecificIntrinsic &intrinsic,
-                  llvm::Optional<mlir::Type> resultType) {
-    llvm::SmallVector<ExtValue> operands;
-
-    llvm::StringRef name = intrinsic.name;
-    mlir::Location loc = getLoc();
-    if (Fortran::lower::intrinsicRequiresCustomOptionalHandling(
-            procRef, intrinsic, converter)) {
-      using ExvAndPresence = std::pair<ExtValue, llvm::Optional<mlir::Value>>;
-      llvm::SmallVector<ExvAndPresence, 4> operands;
-      auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
-        ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr);
-        mlir::Value isPresent =
-            genActualIsPresentTest(builder, loc, optionalArg);
-        operands.emplace_back(optionalArg, isPresent);
-      };
-      auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) {
-        operands.emplace_back(genval(expr), llvm::None);
-      };
-      Fortran::lower::prepareCustomIntrinsicArgument(
-          procRef, intrinsic, resultType, prepareOptionalArg, prepareOtherArg,
-          converter);
-
-      auto getArgument = [&](std::size_t i) -> ExtValue {
-        if (fir::conformsWithPassByRef(
-                fir::getBase(operands[i].first).getType()))
-          return genLoad(operands[i].first);
-        return operands[i].first;
-      };
-      auto isPresent = [&](std::size_t i) -> llvm::Optional<mlir::Value> {
-        return operands[i].second;
-      };
-      return Fortran::lower::lowerCustomIntrinsic(
-          builder, loc, name, resultType, isPresent, getArgument,
-          operands.size(), stmtCtx);
-    }
-
-    const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering =
-        Fortran::lower::getIntrinsicArgumentLowering(name);
-    for (const auto &[arg, dummy] :
-         llvm::zip(procRef.arguments(),
-                   intrinsic.characteristics.value().dummyArguments)) {
-      auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg);
-      if (!expr) {
-        // Absent optional.
-        operands.emplace_back(Fortran::lower::getAbsentIntrinsicArgument());
-        continue;
-      }
-      if (!argLowering) {
-        // No argument lowering instruction, lower by value.
-        operands.emplace_back(genval(*expr));
-        continue;
-      }
-      // Ad-hoc argument lowering handling.
-      Fortran::lower::ArgLoweringRule argRules =
-          Fortran::lower::lowerIntrinsicArgumentAs(loc, *argLowering,
-                                                   dummy.name);
-      if (argRules.handleDynamicOptional &&
-          Fortran::evaluate::MayBePassedAsAbsentOptional(
-              *expr, converter.getFoldingContext())) {
-        ExtValue optional = lowerIntrinsicArgumentAsInquired(*expr);
-        mlir::Value isPresent = genActualIsPresentTest(builder, loc, optional);
-        switch (argRules.lowerAs) {
-        case Fortran::lower::LowerIntrinsicArgAs::Value:
-          operands.emplace_back(
-              genOptionalValue(builder, loc, optional, isPresent));
-          continue;
-        case Fortran::lower::LowerIntrinsicArgAs::Addr:
-          operands.emplace_back(
-              genOptionalAddr(builder, loc, optional, isPresent));
-          continue;
-        case Fortran::lower::LowerIntrinsicArgAs::Box:
-          operands.emplace_back(
-              genOptionalBox(builder, loc, optional, isPresent));
-          continue;
-        case Fortran::lower::LowerIntrinsicArgAs::Inquired:
-          operands.emplace_back(optional);
-          continue;
-        }
-        llvm_unreachable("bad switch");
-      }
-      switch (argRules.lowerAs) {
-      case Fortran::lower::LowerIntrinsicArgAs::Value:
-        operands.emplace_back(genval(*expr));
-        continue;
-      case Fortran::lower::LowerIntrinsicArgAs::Addr:
-        operands.emplace_back(gen(*expr));
-        continue;
-      case Fortran::lower::LowerIntrinsicArgAs::Box:
-        operands.emplace_back(lowerIntrinsicArgumentAsBox(*expr));
-        continue;
-      case Fortran::lower::LowerIntrinsicArgAs::Inquired:
-        operands.emplace_back(lowerIntrinsicArgumentAsInquired(*expr));
-        continue;
-      }
-      llvm_unreachable("bad switch");
-    }
-    // Let the intrinsic library lower the intrinsic procedure call
-    return Fortran::lower::genIntrinsicCall(builder, getLoc(), name, resultType,
-                                            operands, stmtCtx);
-  }
-
   template <typename A>
   bool isScalar(const A &x) {
     return x.Rank() == 0;
   }
 
   /// Helper to detect Transformational function reference.
   template <typename T>
   bool isTransformationalRef(const T &) {

 static bool isAdjustedArrayElementType(mlir::Type t) {
   return fir::isa_char(t) || fir::isa_derived(t) || t.isa<fir::SequenceType>();
 }
 static bool elementTypeWasAdjusted(mlir::Type t) {
   if (auto ty = t.dyn_cast<fir::ReferenceType>())
     return isAdjustedArrayElementType(ty.getEleTy());
   return false;
 }
-
-/// Build an ExtendedValue from a fir.array<?x...?xT> without actually setting
-/// the actual extents and lengths. This is only to allow their propagation as
-/// ExtendedValue without triggering verifier failures when propagating
-/// character/arrays as unboxed values. Only the base of the resulting
-/// ExtendedValue should be used, it is undefined to use the length or extents
-/// of the extended value returned,
-inline static fir::ExtendedValue
-convertToArrayBoxValue(mlir::Location loc, fir::FirOpBuilder &builder,
-                       mlir::Value val, mlir::Value len) {
-  mlir::Type ty = fir::unwrapRefType(val.getType());
-  mlir::IndexType idxTy = builder.getIndexType();
-  auto seqTy = ty.cast<fir::SequenceType>();
-  auto undef = builder.create<fir::UndefOp>(loc, idxTy);
-  llvm::SmallVector<mlir::Value> extents(seqTy.getDimension(), undef);
-  if (fir::isa_char(seqTy.getEleTy()))
-    return fir::CharArrayBoxValue(val, len ? len : undef, extents);
-  return fir::ArrayBoxValue(val, extents);
+static mlir::Type adjustedArrayElementType(mlir::Type t) {
+  return isAdjustedArrayElementType(t) ? fir::ReferenceType::get(t) : t;
 }
 
 /// Helper to generate calls to scalar user defined assignment procedures.
 static void genScalarUserDefinedAssignmentCall(fir::FirOpBuilder &builder,
                                                mlir::Location loc,
                                                mlir::FuncOp func,
                                                const fir::ExtendedValue &lhs,
                                                const fir::ExtendedValue &rhs) {
createCharArrayAmend(mlir::Location loc, fir::FirOpBuilder &builder,
   // For a CHARACTER, we generate the element assignment loops inline.
   helper.createAssign(fir::ExtendedValue{dstChar}, srcExv);
   // Mark this array element as amended.
   mlir::Type ty = innerArg.getType();
   auto amend = builder.create<fir::ArrayAmendOp>(loc, ty, innerArg, dstOp);
   return amend;
 }
 
+/// Build an ExtendedValue from a fir.array<?x...?xT> without actually setting
+/// the actual extents and lengths. This is only to allow their propagation as
+/// ExtendedValue without triggering verifier failures when propagating
+/// character/arrays as unboxed values. Only the base of the resulting
+/// ExtendedValue should be used, it is undefined to use the length or extents
+/// of the extended value returned,
+inline static fir::ExtendedValue
+convertToArrayBoxValue(mlir::Location loc, fir::FirOpBuilder &builder,
+                       mlir::Value val, mlir::Value len) {
+  mlir::Type ty = fir::unwrapRefType(val.getType());
+  mlir::IndexType idxTy = builder.getIndexType();
+  auto seqTy = ty.cast<fir::SequenceType>();
+  auto undef = builder.create<fir::UndefOp>(loc, idxTy);
+  llvm::SmallVector<mlir::Value> extents(seqTy.getDimension(), undef);
+  if (fir::isa_char(seqTy.getEleTy()))
+    return fir::CharArrayBoxValue(val, len ? len : undef, extents);
+  return fir::ArrayBoxValue(val, extents);
+}
+
 //===----------------------------------------------------------------------===//
 //
 // Lowering of array expressions.
 //
 //===----------------------------------------------------------------------===//
 
 namespace {
 class ArrayExprLowering {
ExtValue lowerScalarUserAssignment(mlir::FuncOp userAssignment,
     // 4) Finalize the inner context.
     explicitSpace->finalizeContext();
     // 5). Thread the array value updated forward.
     if (!isIllFormedLHS)
       builder.create<fir::ResultOp>(getLoc(), fir::getBase(lexv));
     return lexv;
   }
 
+private:
+  void determineShapeOfDest(const fir::ExtendedValue &lhs) {
+    destShape = fir::factory::getExtents(builder, getLoc(), lhs);
+  }
+
+  void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) {
+    if (!destShape.empty())
+      return;
+    if (explicitSpaceIsActive() && determineShapeWithSlice(lhs))
+      return;
+    mlir::Type idxTy = builder.getIndexType();
+    mlir::Location loc = getLoc();
+    if (std::optional<Fortran::evaluate::ConstantSubscripts> constantShape =
+            Fortran::evaluate::GetConstantExtents(converter.getFoldingContext(),
+                                                  lhs))
+      for (Fortran::common::ConstantSubscript extent : *constantShape)
+        destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent));
+  }
+
+  bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) {
+    return false;
+  }
+  bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) {
+    TODO(getLoc(), "coarray ref");
+    return false;
+  }
+  bool genShapeFromDataRef(const Fortran::evaluate::Component &x) {
+    return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false;
+  }
+  bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) {
+    if (x.Rank() == 0)
+      return false;
+    if (x.base().Rank() > 0)
+      if (genShapeFromDataRef(x.base()))
+        return true;
+    // x has rank and x.base did not produce a shape.
+    ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base()))
+                                       : asScalarRef(x.base().GetComponent());
+    mlir::Location loc = getLoc();
+    mlir::IndexType idxTy = builder.getIndexType();
+    llvm::SmallVector<mlir::Value> definedShape =
+        fir::factory::getExtents(builder, loc, exv);
+    mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+    for (auto ss : llvm::enumerate(x.subscript())) {
+      std::visit(Fortran::common::visitors{
+                     [&](const Fortran::evaluate::Triplet &trip) {
+                       // For a subscript of triple notation, we compute the
+                       // range of this dimension of the iteration space.
+                       auto lo = [&]() {
+                         if (auto optLo = trip.lower())
+                           return fir::getBase(asScalar(*optLo));
+                         return getLBound(exv, ss.index(), one);
+                       }();
+                       auto hi = [&]() {
+                         if (auto optHi = trip.upper())
+                           return fir::getBase(asScalar(*optHi));
+                         return getUBound(exv, ss.index(), one);
+                       }();
+                       auto step = builder.createConvert(
+                           loc, idxTy, fir::getBase(asScalar(trip.stride())));
+                       auto extent = builder.genExtentFromTriplet(loc, lo, hi,
+                                                                  step, idxTy);
+                       destShape.push_back(extent);
+                     },
+                     [&](auto) {}},
+                 ss.value().u);
+    }
+    return true;
+  }
+  bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) {
+    if (x.IsSymbol())
+      return genShapeFromDataRef(getFirstSym(x));
+    return genShapeFromDataRef(x.GetComponent());
+  }
+  bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) {
+    return std::visit([&](const auto &v) { return genShapeFromDataRef(v); },
+                      x.u);
+  }
+
+  /// When in an explicit space, the ranked component must be evaluated to
+  /// determine the actual number of iterations when slicing triples are
+  /// present. Lower these expressions here.
+  bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) {
+    LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump(
+        llvm::dbgs() << "determine shape of:\n", lhs));
+    // FIXME: We may not want to use ExtractDataRef here since it doesn't deal
+    // with substrings, etc.
+    std::optional<Fortran::evaluate::DataRef> dref =
+        Fortran::evaluate::ExtractDataRef(lhs);
+    return dref.has_value() ? genShapeFromDataRef(*dref) : false;
+  }
+
+  /// CHARACTER and derived type elements are treated as memory references. The
+  /// numeric types are treated as values.
+  static mlir::Type adjustedArraySubtype(mlir::Type ty,
+                                         mlir::ValueRange indices) {
+    mlir::Type pathTy = fir::applyPathToType(ty, indices);
+    assert(pathTy && "indices failed to apply to type");
+    return adjustedArrayElementType(pathTy);
+  }
+
+  ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) {
+    mlir::Type resTy = converter.genType(exp);
+    return std::visit(
+        [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); },
+        exp.u);
+  }
+  ExtValue lowerArrayExpression(const ExtValue &exv) {
+    assert(!explicitSpace);
+    mlir::Type resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType());
+    return lowerArrayExpression(genarr(exv), resTy);
+  }
+
+  void populateBounds(llvm::SmallVectorImpl<mlir::Value> &bounds,
+                      const Fortran::evaluate::Substring *substring) {
+    if (!substring)
+      return;
+    bounds.push_back(fir::getBase(asScalar(substring->lower())));
+    if (auto upper = substring->upper())
+      bounds.push_back(fir::getBase(asScalar(*upper)));
+  }
+
+  /// Default store to destination implementation.
+  /// This implements the default case, which is to assign the value in
+  /// `iters.element` into the destination array, `iters.innerArgument`. Handles
+  /// by value and by reference assignment.
+  CC defaultStoreToDestination(const Fortran::evaluate::Substring *substring) {
+    return [=](IterSpace iterSpace) -> ExtValue {
+      mlir::Location loc = getLoc();
+      mlir::Value innerArg = iterSpace.innerArgument();
+      fir::ExtendedValue exv = iterSpace.elementExv();
+      mlir::Type arrTy = innerArg.getType();
+      mlir::Type eleTy = fir::applyPathToType(arrTy, iterSpace.iterVec());
+      if (isAdjustedArrayElementType(eleTy)) {
+        // The elemental update is in the memref domain. Under this semantics,
+        // we must always copy the computed new element from its location in
+        // memory into the destination array.
+        mlir::Type resRefTy = builder.getRefType(eleTy);
+        // Get a reference to the array element to be amended.
+        auto arrayOp = builder.create<fir::ArrayAccessOp>(
+            loc, resRefTy, innerArg, iterSpace.iterVec(),
+            destination.getTypeparams());
+        if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+          llvm::SmallVector<mlir::Value> substringBounds;
+          populateBounds(substringBounds, substring);
+          mlir::Value dstLen = fir::factory::genLenOfCharacter(
+              builder, loc, destination, iterSpace.iterVec(), substringBounds);
+          fir::ArrayAmendOp amend = createCharArrayAmend(
+              loc, builder, arrayOp, dstLen, exv, innerArg, substringBounds);
+          return abstractArrayExtValue(amend, dstLen);
+        }
+        if (fir::isa_derived(eleTy)) {
+          fir::ArrayAmendOp amend = createDerivedArrayAmend(
+              loc, destination, builder, arrayOp, exv, eleTy, innerArg);
+          return abstractArrayExtValue(amend /*FIXME: typeparams?*/);
+        }
+        assert(eleTy.isa<fir::SequenceType>() && "must be an array");
+        TODO(loc, "array (as element) assignment");
+      }
+      // By value semantics. The element is being assigned by value.
+      mlir::Value ele = builder.createConvert(loc, eleTy, fir::getBase(exv));
+      auto update = builder.create<fir::ArrayUpdateOp>(
+          loc, arrTy, innerArg, ele, iterSpace.iterVec(),
+          destination.getTypeparams());
+      return abstractArrayExtValue(update);
+    };
+  }
+
+  /// For an elemental array expression.
+  ///   1. Lower the scalars and array loads.
+  ///   2. Create the iteration space.
+  ///   3. Create the element-by-element computation in the loop.
+  ///   4. Return the resulting array value.
+  /// If no destination was set in the array context, a temporary of
+  /// \p resultTy will be created to hold the evaluated expression.
+  /// Otherwise, \p resultTy is ignored and the expression is evaluated
+  /// in the destination. \p f is a continuation built from an
+  /// evaluate::Expr or an ExtendedValue.
+  ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) {
+    mlir::Location loc = getLoc();
+    auto [iterSpace, insPt] = genIterSpace(resultTy);
+    auto exv = f(iterSpace);
+    iterSpace.setElement(std::move(exv));
+    auto lambda = ccStoreToDest.hasValue()
+                      ? ccStoreToDest.getValue()
+                      : defaultStoreToDestination(/*substring=*/nullptr);
+    mlir::Value updVal = fir::getBase(lambda(iterSpace));
+    finalizeElementCtx();
+    builder.create<fir::ResultOp>(loc, updVal);
+    builder.restoreInsertionPoint(insPt);
+    return abstractArrayExtValue(iterSpace.outerResult());
+  }
+
+  /// Compute the shape of a slice.
+  llvm::SmallVector<mlir::Value> computeSliceShape(mlir::Value slice) {
+    llvm::SmallVector<mlir::Value> slicedShape;
+    auto slOp = mlir::cast<fir::SliceOp>(slice.getDefiningOp());
+    mlir::Operation::operand_range triples = slOp.getTriples();
+    mlir::IndexType idxTy = builder.getIndexType();
+    mlir::Location loc = getLoc();
+    for (unsigned i = 0, end = triples.size(); i < end; i += 3) {
+      if (!mlir::isa_and_nonnull<fir::UndefOp>(
+              triples[i + 1].getDefiningOp())) {
+        // (..., lb:ub:step, ...) case:  extent = max((ub-lb+step)/step, 0)
+        // See Fortran 2018 9.5.3.3.2 section for more details.
+        mlir::Value res = builder.genExtentFromTriplet(
+            loc, triples[i], triples[i + 1], triples[i + 2], idxTy);
+        slicedShape.emplace_back(res);
+      } else {
+        // do nothing. `..., i, ...` case, so dimension is dropped.
+      }
+    }
+    return slicedShape;
+  }
+
+  /// Get the shape from an ArrayOperand. The shape of the array is adjusted if
+  /// the array was sliced.
+  llvm::SmallVector<mlir::Value> getShape(ArrayOperand array) {
+    if (array.slice)
+      return computeSliceShape(array.slice);
+    if (array.memref.getType().isa<fir::BoxType>())
+      return fir::factory::readExtents(builder, getLoc(),
+                                       fir::BoxValue{array.memref});
+    std::vector<mlir::Value, std::allocator<mlir::Value>> extents =
+        fir::factory::getExtents(array.shape);
+    return {extents.begin(), extents.end()};
+  }
+
+  /// Get the shape from an ArrayLoad.
+  llvm::SmallVector<mlir::Value> getShape(fir::ArrayLoadOp arrayLoad) {
+    return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(),
+                                 arrayLoad.getSlice()});
+  }
+
+  /// Returns the first array operand that may not be absent. If all
+  /// array operands may be absent, return the first one.
+  const ArrayOperand &getInducingShapeArrayOperand() const {
+    assert(!arrayOperands.empty());
+    for (const ArrayOperand &op : arrayOperands)
+      if (!op.mayBeAbsent)
+        return op;
+    // If all arrays operand appears in optional position, then none of them
+    // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the
+    // first operands.
+    // TODO: There is an opportunity to add a runtime check here that
+    // this array is present as required.
+    return arrayOperands[0];
+  }
+
+  /// Generate the shape of the iteration space over the array expression. The
+  /// iteration space may be implicit, explicit, or both. If it is implied it is
+  /// based on the destination and operand array loads, or an optional
+  /// Fortran::evaluate::Shape from the front end. If the shape is explicit,
+  /// this returns any implicit shape component, if it exists.
+  llvm::SmallVector<mlir::Value> genIterationShape() {
+    // Use the precomputed destination shape.
+    if (!destShape.empty())
+      return destShape;
+    // Otherwise, use the destination's shape.
+    if (destination)
+      return getShape(destination);
+    // Otherwise, use the first ArrayLoad operand shape.
+    if (!arrayOperands.empty())
+      return getShape(getInducingShapeArrayOperand());
+    fir::emitFatalError(getLoc(),
+                        "failed to compute the array expression shape");
+  }
+
   bool explicitSpaceIsActive() const {
     return explicitSpace && explicitSpace->isActive();
   }
 
   bool implicitSpaceHasMasks() const {
     return implicitSpace && !implicitSpace->empty();
   }
 
if (implicitSpaceHasMasks()) {
           auto ifOp = builder.create<fir::IfOp>(
               loc, mlir::TypeRange{innerArg.getType()}, fir::getBase(cond),
               /*withElseRegion=*/true);
           builder.create<fir::ResultOp>(loc, ifOp.getResult(0));
           builder.setInsertionPointToStart(&ifOp.getElseRegion().front());
           builder.create<fir::ResultOp>(loc, innerArg);
           builder.setInsertionPointToStart(&ifOp.getThenRegion().front());
         };
-        for (std::size_t i = 0; i < size; ++i)
+        for (std::remove_const_t<decltype(size)> i = 0; i < size; ++i)
           if (const auto *e = maskExprs[i])
             genFalseBlock(e, genCond(e, iters));
 
         // The last condition is either non-negated or unconditionally negated.
         if (const auto *e = maskExprs[size])
           genTrueBlock(e, genCond(e, iters));
       }
     }
private:
   /// descriptor). The returned expression cannot be addressed directly, it is
   /// meant to inquire about its status before addressing the related entity.
   template <typename A>
   ExtValue asInquired(const A &x) {
     return ScalarExprLowering{getLoc(), converter, symMap, stmtCtx}
         .lowerIntrinsicArgumentAsInquired(x);
   }
 
-  // An expression with non-zero rank is an array expression.
-  template <typename A>
-  bool isArray(const A &x) const {
-    return x.Rank() != 0;
-  }
-
   /// Some temporaries are allocated on an element-by-element basis during the
   /// array expression evaluation. Collect the cleanups here so the resources
   /// can be freed before the next loop iteration, avoiding memory leaks. etc.
   Fortran::lower::StatementContext &getElementCtx() {
     if (!elementCtx) {
       stmtCtx.pushScope();
       elementCtx = true;
     }
CC genProcRef(const Fortran::evaluate::ProcedureRef &procRef,
     }
     // In the default case, the call can be hoisted out of the loop nest. Apply
     // the iterations to the result, which may be an array value.
     return genarr(
         ScalarExprLowering{loc, converter, symMap, stmtCtx}.genProcedureRef(
             procRef, retTy));
   }
 
+  CC genarr(const Fortran::evaluate::ProcedureDesignator &) {
+    TODO(getLoc(), "procedure designator");
+  }
+  CC genarr(const Fortran::evaluate::ProcedureRef &x) {
+    if (x.hasAlternateReturns())
+      fir::emitFatalError(getLoc(),
+                          "array procedure reference with alt-return");
+    return genProcRef(x, llvm::None);
+  }
   template <typename A>
   CC genScalarAndForwardValue(const A &x) {
     ExtValue result = asScalar(x);
     return [=](IterSpace) { return result; };
   }
-
   template <typename A, typename = std::enable_if_t<Fortran::common::HasMember<
                             A, Fortran::evaluate::TypelessExpression>>>
   CC genarr(const A &x) {
     return genScalarAndForwardValue(x);
   }
 
   template <typename A>
   CC genarr(const Fortran::evaluate::Expr<A> &x) {
return [=](IterSpace iters) -> ExtValue {
           !(fir::isa_ref_type(valTy) && fir::isa_integer(ty)))
         return convertAdjustedType(builder, loc, ty, exv);
       return builder.createConvert(loc, ty, val);
     };
   }
 
   template <int KIND>
   CC genarr(const Fortran::evaluate::ComplexComponent<KIND> &x) {
-    TODO(getLoc(), "ComplexComponent<KIND>");
+    mlir::Location loc = getLoc();
+    auto lambda = genarr(x.left());
+    bool isImagPart = x.isImaginaryPart;
+    return [=](IterSpace iters) -> ExtValue {
+      mlir::Value lhs = fir::getBase(lambda(iters));
+      return fir::factory::Complex{builder, loc}.extractComplexPart(lhs,
+                                                                    isImagPart);
+    };
   }
 
   template <typename T>
   CC genarr(const Fortran::evaluate::Parentheses<T> &x) {
     mlir::Location loc = getLoc();
     if (isReferentiallyOpaque()) {
       // Context is a call argument in, for example, an elemental procedure
       // call. TODO: all array arguments should use array_load, array_access,
return [=](IterSpace iters) -> ExtValue {
       mlir::Value lhs = fir::getBase(lf(iters));
       mlir::Value rhs = fir::getBase(rf(iters));
       return Fortran::lower::genPow(builder, loc, ty, lhs, rhs);
     };
   }
   template <Fortran::common::TypeCategory TC, int KIND>
   CC genarr(
       const Fortran::evaluate::Extremum<Fortran::evaluate::Type<TC, KIND>> &x) {
-    TODO(getLoc(), "genarr Extremum<Fortran::evaluate::Type<TC, KIND>>");
+    mlir::Location loc = getLoc();
+    auto lf = genarr(x.left());
+    auto rf = genarr(x.right());
+    switch (x.ordering) {
+    case Fortran::evaluate::Ordering::Greater:
+      return [=](IterSpace iters) -> ExtValue {
+        mlir::Value lhs = fir::getBase(lf(iters));
+        mlir::Value rhs = fir::getBase(rf(iters));
+        return Fortran::lower::genMax(builder, loc,
+                                      llvm::ArrayRef<mlir::Value>{lhs, rhs});
+      };
+    case Fortran::evaluate::Ordering::Less:
+      return [=](IterSpace iters) -> ExtValue {
+        mlir::Value lhs = fir::getBase(lf(iters));
+        mlir::Value rhs = fir::getBase(rf(iters));
+        return Fortran::lower::genMin(builder, loc,
+                                      llvm::ArrayRef<mlir::Value>{lhs, rhs});
+      };
+    case Fortran::evaluate::Ordering::Equal:
+      llvm_unreachable("Equal is not a valid ordering in this context");
+    }
+    llvm_unreachable("unknown ordering");
   }
   template <Fortran::common::TypeCategory TC, int KIND>
   CC genarr(
       const Fortran::evaluate::RealToIntPower<Fortran::evaluate::Type<TC, KIND>>
           &x) {
-    TODO(getLoc(), "genarr RealToIntPower<Fortran::evaluate::Type<TC, KIND>>");
+    mlir::Location loc = getLoc();
+    auto ty = converter.genType(TC, KIND);
+    auto lf = genarr(x.left());
+    auto rf = genarr(x.right());
+    return [=](IterSpace iters) {
+      mlir::Value lhs = fir::getBase(lf(iters));
+      mlir::Value rhs = fir::getBase(rf(iters));
+      return Fortran::lower::genPow(builder, loc, ty, lhs, rhs);
+    };
   }
   template <int KIND>
   CC genarr(const Fortran::evaluate::ComplexConstructor<KIND> &x) {
-    TODO(getLoc(), "genarr ComplexConstructor<KIND>");
+    mlir::Location loc = getLoc();
+    auto lf = genarr(x.left());
+    auto rf = genarr(x.right());
+    return [=](IterSpace iters) -> ExtValue {
+      mlir::Value lhs = fir::getBase(lf(iters));
+      mlir::Value rhs = fir::getBase(rf(iters));
+      return fir::factory::Complex{builder, loc}.createComplex(KIND, lhs, rhs);
+    };
   }
 
   /// Fortran's concatenation operator `//`.
   template <int KIND>
   CC genarr(const Fortran::evaluate::Concat<KIND> &x) {
     mlir::Location loc = getLoc();
     auto lf = genarr(x.left());
     auto rf = genarr(x.right());
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
   /// Return the extent of the boxed array `x` in dimesion `dim`.
   mlir::Value getExtent(const ExtValue &x, unsigned dim) {
     return fir::factory::readExtent(builder, getLoc(), x, dim);
   }
 
   template <typename A>
   ExtValue genArrayBase(const A &base) {
     ScalarExprLowering sel{getLoc(), converter, symMap, stmtCtx};
-    return base.IsSymbol() ? sel.gen(base.GetFirstSymbol())
+    return base.IsSymbol() ? sel.gen(getFirstSym(base))
                            : sel.gen(base.GetComponent());
   }
 
   template <typename A>
   bool hasEvArrayRef(const A &x) {
     struct HasEvArrayRefHelper
         : public Fortran::evaluate::AnyTraverse<HasEvArrayRefHelper> {
       HasEvArrayRefHelper()
for (auto sub : llvm::enumerate(x.subscript())) {
                 }
               }},
           sub.value().u);
     }
     if (!useSlice)
       trips.clear();
   }
 
+  static mlir::Type unwrapBoxEleTy(mlir::Type ty) {
+    if (auto boxTy = ty.dyn_cast<fir::BoxType>())
+      return fir::unwrapRefType(boxTy.getEleTy());
+    return ty;
+  }
+
+  llvm::SmallVector<mlir::Value> getShape(mlir::Type ty) {
+    llvm::SmallVector<mlir::Value> result;
+    ty = unwrapBoxEleTy(ty);
+    mlir::Location loc = getLoc();
+    mlir::IndexType idxTy = builder.getIndexType();
+    for (auto extent : ty.cast<fir::SequenceType>().getShape()) {
+      auto v = extent == fir::SequenceType::getUnknownExtent()
+                   ? builder.create<fir::UndefOp>(loc, idxTy).getResult()
+                   : builder.createIntegerConstant(loc, idxTy, extent);
+      result.push_back(v);
+    }
+    return result;
+  }
+
   CC genarr(const Fortran::semantics::SymbolRef &sym,
             ComponentPath &components) {
     return genarr(sym.get(), components);
   }
 
   ExtValue abstractArrayExtValue(mlir::Value val, mlir::Value len = {}) {
     return convertToArrayBoxValue(getLoc(), builder, val, len);
   }
 
   CC genarr(const ExtValue &extMemref) {
     ComponentPath dummy(/*isImplicit=*/true);
     return genarr(extMemref, dummy);
   }
 
+  /// Base case of generating an array reference,
+  CC genarr(const ExtValue &extMemref, ComponentPath &components) {
+    mlir::Location loc = getLoc();
+    mlir::Value memref = fir::getBase(extMemref);
+    mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType());
+    assert(arrTy.isa<fir::SequenceType>() && "memory ref must be an array");
+    mlir::Value shape = builder.createShape(loc, extMemref);
+    mlir::Value slice;
+    if (components.isSlice()) {
+      if (isBoxValue() && components.substring) {
+        // Append the substring operator to emboxing Op as it will become an
+        // interior adjustment (add offset, adjust LEN) to the CHARACTER value
+        // being referenced in the descriptor.
+        llvm::SmallVector<mlir::Value> substringBounds;
+        populateBounds(substringBounds, components.substring);
+        // Convert to (offset, size)
+        mlir::Type iTy = substringBounds[0].getType();
+        if (substringBounds.size() != 2) {
+          fir::CharacterType charTy =
+              fir::factory::CharacterExprHelper::getCharType(arrTy);
+          if (charTy.hasConstantLen()) {
+            mlir::IndexType idxTy = builder.getIndexType();
+            fir::CharacterType::LenType charLen = charTy.getLen();
+            mlir::Value lenValue =
+                builder.createIntegerConstant(loc, idxTy, charLen);
+            substringBounds.push_back(lenValue);
+          } else {
+            llvm::SmallVector<mlir::Value> typeparams =
+                fir::getTypeParams(extMemref);
+            substringBounds.push_back(typeparams.back());
+          }
+        }
+        // Convert the lower bound to 0-based substring.
+        mlir::Value one =
+            builder.createIntegerConstant(loc, substringBounds[0].getType(), 1);
+        substringBounds[0] =
+            builder.create<mlir::arith::SubIOp>(loc, substringBounds[0], one);
+        // Convert the upper bound to a length.
+        mlir::Value cast = builder.createConvert(loc, iTy, substringBounds[1]);
+        mlir::Value zero = builder.createIntegerConstant(loc, iTy, 0);
+        auto size =
+            builder.create<mlir::arith::SubIOp>(loc, cast, substringBounds[0]);
+        auto cmp = builder.create<mlir::arith::CmpIOp>(
+            loc, mlir::arith::CmpIPredicate::sgt, size, zero);
+        // size = MAX(upper - (lower - 1), 0)
+        substringBounds[1] =
+            builder.create<mlir::arith::SelectOp>(loc, cmp, size, zero);
+        slice = builder.create<fir::SliceOp>(loc, components.trips,
+                                             components.suffixComponents,
+                                             substringBounds);
+      } else {
+        slice = builder.createSlice(loc, extMemref, components.trips,
+                                    components.suffixComponents);
+      }
+      if (components.hasComponents()) {
+        auto seqTy = arrTy.cast<fir::SequenceType>();
+        mlir::Type eleTy =
+            fir::applyPathToType(seqTy.getEleTy(), components.suffixComponents);
+        if (!eleTy)
+          fir::emitFatalError(loc, "slicing path is ill-formed");
+        if (auto realTy = eleTy.dyn_cast<fir::RealType>())
+          eleTy = Fortran::lower::convertReal(realTy.getContext(),
+                                              realTy.getFKind());
+
+        // create the type of the projected array.
+        arrTy = fir::SequenceType::get(seqTy.getShape(), eleTy);
+        LLVM_DEBUG(llvm::dbgs()
+                   << "type of array projection from component slicing: "
+                   << eleTy << ", " << arrTy << '\n');
+      }
+    }
+    arrayOperands.push_back(ArrayOperand{memref, shape, slice});
+    if (destShape.empty())
+      destShape = getShape(arrayOperands.back());
+    if (isBoxValue()) {
+      // Semantics are a reference to a boxed array.
+      // This case just requires that an embox operation be created to box the
+      // value. The value of the box is forwarded in the continuation.
+      mlir::Type reduceTy = reduceRank(arrTy, slice);
+      auto boxTy = fir::BoxType::get(reduceTy);
+      if (components.substring) {
+        // Adjust char length to substring size.
+        fir::CharacterType charTy =
+            fir::factory::CharacterExprHelper::getCharType(reduceTy);
+        auto seqTy = reduceTy.cast<fir::SequenceType>();
+        // TODO: Use a constant for fir.char LEN if we can compute it.
+        boxTy = fir::BoxType::get(
+            fir::SequenceType::get(fir::CharacterType::getUnknownLen(
+                                       builder.getContext(), charTy.getFKind()),
+                                   seqTy.getDimension()));
+      }
+      mlir::Value embox =
+          memref.getType().isa<fir::BoxType>()
+              ? builder.create<fir::ReboxOp>(loc, boxTy, memref, shape, slice)
+                    .getResult()
+              : builder
+                    .create<fir::EmboxOp>(loc, boxTy, memref, shape, slice,
+                                          fir::getTypeParams(extMemref))
+                    .getResult();
+      return [=](IterSpace) -> ExtValue { return fir::BoxValue(embox); };
+    }
+    auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
+    if (isReferentiallyOpaque()) {
+      // Semantics are an opaque reference to an array.
+      // This case forwards a continuation that will generate the address
+      // arithmetic to the array element. This does not have copy-in/copy-out
+      // semantics. No attempt to copy the array value will be made during the
+      // interpretation of the Fortran statement.
+      mlir::Type refEleTy = builder.getRefType(eleTy);
+      return [=](IterSpace iters) -> ExtValue {
+        // ArrayCoorOp does not expect zero based indices.
+        llvm::SmallVector<mlir::Value> indices = fir::factory::originateIndices(
+            loc, builder, memref.getType(), shape, iters.iterVec());
+        mlir::Value coor = builder.create<fir::ArrayCoorOp>(
+            loc, refEleTy, memref, shape, slice, indices,
+            fir::getTypeParams(extMemref));
+        if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+          llvm::SmallVector<mlir::Value> substringBounds;
+          populateBounds(substringBounds, components.substring);
+          if (!substringBounds.empty()) {
+            mlir::Value dstLen = fir::factory::genLenOfCharacter(
+                builder, loc, arrTy.cast<fir::SequenceType>(), memref,
+                fir::getTypeParams(extMemref), iters.iterVec(),
+                substringBounds);
+            fir::CharBoxValue dstChar(coor, dstLen);
+            return fir::factory::CharacterExprHelper{builder, loc}
+                .createSubstring(dstChar, substringBounds);
+          }
+        }
+        return fir::factory::arraySectionElementToExtendedValue(
+            builder, loc, extMemref, coor, slice);
+      };
+    }
+    auto arrLoad = builder.create<fir::ArrayLoadOp>(
+        loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref));
+    mlir::Value arrLd = arrLoad.getResult();
+    if (isProjectedCopyInCopyOut()) {
+      // Semantics are projected copy-in copy-out.
+      // The backing store of the destination of an array expression may be
+      // partially modified. These updates are recorded in FIR by forwarding a
+      // continuation that generates an `array_update` Op. The destination is
+      // always loaded at the beginning of the statement and merged at the
+      // end.
+      destination = arrLoad;
+      auto lambda = ccStoreToDest.hasValue()
+                        ? ccStoreToDest.getValue()
+                        : defaultStoreToDestination(components.substring);
+      return [=](IterSpace iters) -> ExtValue { return lambda(iters); };
+    }
+    if (isCustomCopyInCopyOut()) {
+      // Create an array_modify to get the LHS element address and indicate
+      // the assignment, the actual assignment must be implemented in
+      // ccStoreToDest.
+      destination = arrLoad;
+      return [=](IterSpace iters) -> ExtValue {
+        mlir::Value innerArg = iters.innerArgument();
+        mlir::Type resTy = innerArg.getType();
+        mlir::Type eleTy = fir::applyPathToType(resTy, iters.iterVec());
+        mlir::Type refEleTy =
+            fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy);
+        auto arrModify = builder.create<fir::ArrayModifyOp>(
+            loc, mlir::TypeRange{refEleTy, resTy}, innerArg, iters.iterVec(),
+            destination.getTypeparams());
+        return abstractArrayExtValue(arrModify.getResult(1));
+      };
+    }
+    if (isCopyInCopyOut()) {
+      // Semantics are copy-in copy-out.
+      // The continuation simply forwards the result of the `array_load` Op,
+      // which is the value of the array as it was when loaded. All data
+      // references with rank > 0 in an array expression typically have
+      // copy-in copy-out semantics.
+      return [=](IterSpace) -> ExtValue { return arrLd; };
+    }
+    mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams();
+    if (isValueAttribute()) {
+      // Semantics are value attribute.
+      // Here the continuation will `array_fetch` a value from an array and
+      // then store that value in a temporary. One can thus imitate pass by
+      // value even when the call is pass by reference.
+      return [=](IterSpace iters) -> ExtValue {
+        mlir::Value base;
+        mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
+        if (isAdjustedArrayElementType(eleTy)) {
+          mlir::Type eleRefTy = builder.getRefType(eleTy);
+          base = builder.create<fir::ArrayAccessOp>(
+              loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
+        } else {
+          base = builder.create<fir::ArrayFetchOp>(
+              loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
+        }
+        mlir::Value temp = builder.createTemporary(
+            loc, base.getType(),
+            llvm::ArrayRef<mlir::NamedAttribute>{
+                Fortran::lower::getAdaptToByRefAttr(builder)});
+        builder.create<fir::StoreOp>(loc, base, temp);
+        return fir::factory::arraySectionElementToExtendedValue(
+            builder, loc, extMemref, temp, slice);
+      };
+    }
+    // In the default case, the array reference forwards an `array_fetch` or
+    // `array_access` Op in the continuation.
+    return [=](IterSpace iters) -> ExtValue {
+      mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
+      if (isAdjustedArrayElementType(eleTy)) {
+        mlir::Type eleRefTy = builder.getRefType(eleTy);
+        mlir::Value arrayOp = builder.create<fir::ArrayAccessOp>(
+            loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
+        if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
+          llvm::SmallVector<mlir::Value> substringBounds;
+          populateBounds(substringBounds, components.substring);
+          if (!substringBounds.empty()) {
+            mlir::Value dstLen = fir::factory::genLenOfCharacter(
+                builder, loc, arrLoad, iters.iterVec(), substringBounds);
+            fir::CharBoxValue dstChar(arrayOp, dstLen);
+            return fir::factory::CharacterExprHelper{builder, loc}
+                .createSubstring(dstChar, substringBounds);
+          }
+        }
+        return fir::factory::arraySectionElementToExtendedValue(
+            builder, loc, extMemref, arrayOp, slice);
+      }
+      auto arrFetch = builder.create<fir::ArrayFetchOp>(
+          loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
+      return fir::factory::arraySectionElementToExtendedValue(
+          builder, loc, extMemref, arrFetch, slice);
+    };
+  }
+
+  /// Given an optional fir.box, returns an fir.box that is the original one if
+  /// it is present and it otherwise an unallocated box.
+  /// Absent fir.box are implemented as a null pointer descriptor. Generated
+  /// code may need to unconditionally read a fir.box that can be absent.
+  /// This helper allows creating a fir.box that can be read in all cases
+  /// outside of a fir.if (isPresent) region. However, the usages of the value
+  /// read from such box should still only be done in a fir.if(isPresent).
+  static fir::ExtendedValue
+  absentBoxToUnalllocatedBox(fir::FirOpBuilder &builder, mlir::Location loc,
+                             const fir::ExtendedValue &exv,
+                             mlir::Value isPresent) {
+    mlir::Value box = fir::getBase(exv);
+    mlir::Type boxType = box.getType();
+    assert(boxType.isa<fir::BoxType>() && "argument must be a fir.box");
+    mlir::Value emptyBox =
+        fir::factory::createUnallocatedBox(builder, loc, boxType, llvm::None);
+    auto safeToReadBox =
+        builder.create<mlir::arith::SelectOp>(loc, isPresent, box, emptyBox);
+    return fir::substBase(exv, safeToReadBox);
+  }
+
+  std::tuple<CC, mlir::Value, mlir::Type>
+  genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) {
+    assert(expr.Rank() > 0 && "expr must be an array");
+    mlir::Location loc = getLoc();
+    ExtValue optionalArg = asInquired(expr);
+    mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
+    // Generate an array load and access to an array that may be an absent
+    // optional or an unallocated optional.
+    mlir::Value base = getBase(optionalArg);
+    const bool hasOptionalAttr =
+        fir::valueHasFirAttribute(base, fir::getOptionalAttrName());
+    mlir::Type baseType = fir::unwrapRefType(base.getType());
+    const bool isBox = baseType.isa<fir::BoxType>();
+    const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject(
+        expr, converter.getFoldingContext());
+    mlir::Type arrType = fir::unwrapPassByRefType(baseType);
+    mlir::Type eleType = fir::unwrapSequenceType(arrType);
+    ExtValue exv = optionalArg;
+    if (hasOptionalAttr && isBox && !isAllocOrPtr) {
+      // Elemental argument cannot be allocatable or pointers (C15100).
+      // Hence, per 15.5.2.12 3 (8) and (9), the provided Allocatable and
+      // Pointer optional arrays cannot be absent. The only kind of entities
+      // that can get here are optional assumed shape and polymorphic entities.
+      exv = absentBoxToUnalllocatedBox(builder, loc, exv, isPresent);
+    }
+    // All the properties can be read from any fir.box but the read values may
+    // be undefined and should only be used inside a fir.if (canBeRead) region.
+    if (const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>())
+      exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox);
+
+    mlir::Value memref = fir::getBase(exv);
+    mlir::Value shape = builder.createShape(loc, exv);
+    mlir::Value noSlice;
+    auto arrLoad = builder.create<fir::ArrayLoadOp>(
+        loc, arrType, memref, shape, noSlice, fir::getTypeParams(exv));
+    mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams();
+    mlir::Value arrLd = arrLoad.getResult();
+    // Mark the load to tell later passes it is unsafe to use this array_load
+    // shape unconditionally.
+    arrLoad->setAttr(fir::getOptionalAttrName(), builder.getUnitAttr());
+
+    // Place the array as optional on the arrayOperands stack so that its
+    // shape will only be used as a fallback to induce the implicit loop nest
+    // (that is if there is no non optional array arguments).
+    arrayOperands.push_back(
+        ArrayOperand{memref, shape, noSlice, /*mayBeAbsent=*/true});
+
+    // By value semantics.
+    auto cc = [=](IterSpace iters) -> ExtValue {
+      auto arrFetch = builder.create<fir::ArrayFetchOp>(
+          loc, eleType, arrLd, iters.iterVec(), arrLdTypeParams);
+      return fir::factory::arraySectionElementToExtendedValue(
+          builder, loc, exv, arrFetch, noSlice);
+    };
+    return {cc, isPresent, eleType};
+  }
+
+  /// Generate a continuation to pass \p expr to an OPTIONAL argument of an
+  /// elemental procedure. This is meant to handle the cases where \p expr might
+  /// be dynamically absent (i.e. when it is a POINTER, an ALLOCATABLE or an
+  /// OPTIONAL variable). If p\ expr is guaranteed to be present genarr() can
+  /// directly be called instead.
+  CC genarrForwardOptionalArgumentToCall(const Fortran::lower::SomeExpr &expr) {
+    mlir::Location loc = getLoc();
+    // Only by-value numerical and logical so far.
+    if (semant != ConstituentSemantics::RefTransparent)
+      TODO(loc, "optional arguments in user defined elemental procedures");
+
+    // Handle scalar argument case (the if-then-else is generated outside of the
+    // implicit loop nest).
+    if (expr.Rank() == 0) {
+      ExtValue optionalArg = asInquired(expr);
+      mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
+      mlir::Value elementValue =
+          fir::getBase(genOptionalValue(builder, loc, optionalArg, isPresent));
+      return [=](IterSpace iters) -> ExtValue { return elementValue; };
+    }
+
+    CC cc;
+    mlir::Value isPresent;
+    mlir::Type eleType;
+    std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr);
+    return [=](IterSpace iters) -> ExtValue {
+      mlir::Value elementValue =
+          builder
+              .genIfOp(loc, {eleType}, isPresent,
+                       /*withElseRegion=*/true)
+              .genThen([&]() {
+                builder.create<fir::ResultOp>(loc, fir::getBase(cc(iters)));
+              })
+              .genElse([&]() {
+                mlir::Value zero =
+                    fir::factory::createZeroValue(builder, loc, eleType);
+                builder.create<fir::ResultOp>(loc, zero);
+              })
+              .getResults()[0];
+      return elementValue;
+    };
+  }
+
+  /// Reduce the rank of a array to be boxed based on the slice's operands.
+  static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) {
+    if (slice) {
+      auto slOp = mlir::dyn_cast<fir::SliceOp>(slice.getDefiningOp());
+      assert(slOp && "expected slice op");
+      auto seqTy = arrTy.dyn_cast<fir::SequenceType>();
+      assert(seqTy && "expected array type");
+      mlir::Operation::operand_range triples = slOp.getTriples();
+      fir::SequenceType::Shape shape;
+      // reduce the rank for each invariant dimension
+      for (unsigned i = 1, end = triples.size(); i < end; i += 3)
+        if (!mlir::isa_and_nonnull<fir::UndefOp>(triples[i].getDefiningOp()))
+          shape.push_back(fir::SequenceType::getUnknownExtent());
+      return fir::SequenceType::get(shape, seqTy.getEleTy());
+    }
+    // not sliced, so no change in rank
+    return arrTy;
+  }
+
+  /// Example: <code>array%RE</code>
+  CC genarr(const Fortran::evaluate::ComplexPart &x,
+            ComponentPath &components) {
+    components.reversePath.push_back(&x);
+    return genarr(x.complex(), components);
+  }
+
+  template <typename A>
+  CC genSlicePath(const A &x, ComponentPath &components) {
+    return genarr(x, components);
+  }
+
+  CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &,
+            ComponentPath &components) {
+    fir::emitFatalError(getLoc(), "substring of static array object");
+  }
+
+  /// Substrings (see 9.4.1)
+  CC genarr(const Fortran::evaluate::Substring &x, ComponentPath &components) {
+    components.substring = &x;
+    return std::visit([&](const auto &v) { return genarr(v, components); },
+                      x.parent());
+  }
+
+  template <typename T>
+  CC genarr(const Fortran::evaluate::FunctionRef<T> &funRef) {
+    // Note that it's possible that the function being called returns either an
+    // array or a scalar.  In the first case, use the element type of the array.
+    return genProcRef(
+        funRef, fir::unwrapSequenceType(converter.genType(toEvExpr(funRef))));
+  }
+
   //===--------------------------------------------------------------------===//
   // Array construction
   //===--------------------------------------------------------------------===//
 
   /// Target agnostic computation of the size of an element in the array.
   /// Returns the size in bytes with type `index` or a null Value if the element
   /// size is not constant.
   mlir::Value computeElementSize(const ExtValue &exv, mlir::Type eleTy,
if (fir::isa_char(seqTy.getEleTy())) {
         return genarr(fir::CharArrayBoxValue{mem, len, extents});
       }
       return genarr(fir::CharArrayBoxValue{mem, zero, extents});
     }
     return genarr(fir::ArrayBoxValue{mem, extents});
   }
 
   CC genarr(const Fortran::evaluate::ImpliedDoIndex &) {
-    TODO(getLoc(), "genarr ImpliedDoIndex");
+    fir::emitFatalError(getLoc(), "implied do index cannot have rank > 0");
   }
-
   CC genarr(const Fortran::evaluate::TypeParamInquiry &x) {
-    TODO(getLoc(), "genarr TypeParamInquiry");
+    TODO(getLoc(), "array expr type parameter inquiry");
+    return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
   }
-
   CC genarr(const Fortran::evaluate::DescriptorInquiry &x) {
-    TODO(getLoc(), "genarr DescriptorInquiry");
+    TODO(getLoc(), "array expr descriptor inquiry");
+    return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
   }
-
   CC genarr(const Fortran::evaluate::StructureConstructor &x) {
-    TODO(getLoc(), "genarr StructureConstructor");
+    TODO(getLoc(), "structure constructor");
+    return [](IterSpace iters) -> ExtValue { return mlir::Value{}; };
   }
 
   //===--------------------------------------------------------------------===//
   // LOCICAL operators (.NOT., .AND., .EQV., etc.)
   //===--------------------------------------------------------------------===//
 
   template <int KIND>
   CC genarr(const Fortran::evaluate::Not<KIND> &x) {

 
   template <typename A>
   CC genarr(const Fortran::evaluate::Designator<A> &des) {
     ComponentPath components(des.Rank() > 0);
     return std::visit([&](const auto &x) { return genarr(x, components); },
                       des.u);
   }
 
-  template <typename T>
-  CC genarr(const Fortran::evaluate::FunctionRef<T> &funRef) {
-    // Note that it's possible that the function being called returns either an
-    // array or a scalar.  In the first case, use the element type of the array.
-    return genProcRef(
-        funRef, fir::unwrapSequenceType(converter.genType(toEvExpr(funRef))));
+  /// Is the path component rank > 0?
+  static bool ranked(const PathComponent &x) {
+    return std::visit(Fortran::common::visitors{
+                          [](const ImplicitSubscripts &) { return false; },
+                          [](const auto *v) { return v->Rank() > 0; }},
+                      x);
   }
 
   //===-------------------------------------------------------------------===//
   // Array data references in an explicit iteration space.
   //
   // Use the base array that was loaded before the loop nest.
   //===-------------------------------------------------------------------===//
 
CC genImplicitArrayAccess(const A &x, ComponentPath &components) {
     ExtValue exv = asScalarRef(x);
     lowerPath(exv, components);
     auto lambda = genarr(exv, components);
     return [=](IterSpace iters) { return lambda(components.pc(iters)); };
   }
   CC genImplicitArrayAccess(const Fortran::evaluate::NamedEntity &x,
                             ComponentPath &components) {
     if (x.IsSymbol())
-      return genImplicitArrayAccess(x.GetFirstSymbol(), components);
+      return genImplicitArrayAccess(getFirstSym(x), components);
     return genImplicitArrayAccess(x.GetComponent(), components);
   }
 
   template <typename A>
   CC genAsScalar(const A &x) {
     mlir::Location loc = getLoc();
     if (isProjectedCopyInCopyOut()) {
       return [=, &x, builder = &converter.getFirOpBuilder()](
                  IterSpace iters) -> ExtValue {
         ExtValue exv = asScalarRef(x);
         mlir::Value val = fir::getBase(exv);
         mlir::Type eleTy = fir::unwrapRefType(val.getType());
         if (isAdjustedArrayElementType(eleTy)) {
           if (fir::isa_char(eleTy)) {
-            TODO(getLoc(), "assignment of character type");
+            fir::factory::CharacterExprHelper{*builder, loc}.createAssign(
+                exv, iters.elementExv());
           } else if (fir::isa_derived(eleTy)) {
             TODO(loc, "assignment of derived type");
           } else {
             fir::emitFatalError(loc, "array type not expected in scalar");
           }
         } else {
           builder->create<fir::StoreOp>(loc, iters.getElement(), val);
         }

   }
 
   CC genarr(const Fortran::evaluate::CoarrayRef &x, ComponentPath &components) {
     TODO(getLoc(), "coarray reference");
   }
 
   CC genarr(const Fortran::evaluate::NamedEntity &x,
             ComponentPath &components) {
-    return x.IsSymbol() ? genarr(x.GetFirstSymbol(), components)
+    return x.IsSymbol() ? genarr(getFirstSym(x), components)
                         : genarr(x.GetComponent(), components);
   }
 
   CC genarr(const Fortran::evaluate::DataRef &x, ComponentPath &components) {
     return std::visit([&](const auto &v) { return genarr(v, components); },
                       x.u);
   }
 
   bool pathIsEmpty(const ComponentPath &components) {
     return components.reversePath.empty();
   }
 
-  /// Given an optional fir.box, returns an fir.box that is the original one if
-  /// it is present and it otherwise an unallocated box.
-  /// Absent fir.box are implemented as a null pointer descriptor. Generated
-  /// code may need to unconditionally read a fir.box that can be absent.
-  /// This helper allows creating a fir.box that can be read in all cases
-  /// outside of a fir.if (isPresent) region. However, the usages of the value
-  /// read from such box should still only be done in a fir.if(isPresent).
-  static fir::ExtendedValue
-  absentBoxToUnalllocatedBox(fir::FirOpBuilder &builder, mlir::Location loc,
-                             const fir::ExtendedValue &exv,
-                             mlir::Value isPresent) {
-    mlir::Value box = fir::getBase(exv);
-    mlir::Type boxType = box.getType();
-    assert(boxType.isa<fir::BoxType>() && "argument must be a fir.box");
-    mlir::Value emptyBox =
-        fir::factory::createUnallocatedBox(builder, loc, boxType, llvm::None);
-    auto safeToReadBox =
-        builder.create<mlir::arith::SelectOp>(loc, isPresent, box, emptyBox);
-    return fir::substBase(exv, safeToReadBox);
-  }
-
-  std::tuple<CC, mlir::Value, mlir::Type>
-  genOptionalArrayFetch(const Fortran::lower::SomeExpr &expr) {
-    assert(expr.Rank() > 0 && "expr must be an array");
-    mlir::Location loc = getLoc();
-    ExtValue optionalArg = asInquired(expr);
-    mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
-    // Generate an array load and access to an array that may be an absent
-    // optional or an unallocated optional.
-    mlir::Value base = getBase(optionalArg);
-    const bool hasOptionalAttr =
-        fir::valueHasFirAttribute(base, fir::getOptionalAttrName());
-    mlir::Type baseType = fir::unwrapRefType(base.getType());
-    const bool isBox = baseType.isa<fir::BoxType>();
-    const bool isAllocOrPtr = Fortran::evaluate::IsAllocatableOrPointerObject(
-        expr, converter.getFoldingContext());
-    mlir::Type arrType = fir::unwrapPassByRefType(baseType);
-    mlir::Type eleType = fir::unwrapSequenceType(arrType);
-    ExtValue exv = optionalArg;
-    if (hasOptionalAttr && isBox && !isAllocOrPtr) {
-      // Elemental argument cannot be allocatable or pointers (C15100).
-      // Hence, per 15.5.2.12 3 (8) and (9), the provided Allocatable and
-      // Pointer optional arrays cannot be absent. The only kind of entities
-      // that can get here are optional assumed shape and polymorphic entities.
-      exv = absentBoxToUnalllocatedBox(builder, loc, exv, isPresent);
-    }
-    // All the properties can be read from any fir.box but the read values may
-    // be undefined and should only be used inside a fir.if (canBeRead) region.
-    if (const auto *mutableBox = exv.getBoxOf<fir::MutableBoxValue>())
-      exv = fir::factory::genMutableBoxRead(builder, loc, *mutableBox);
-
-    mlir::Value memref = fir::getBase(exv);
-    mlir::Value shape = builder.createShape(loc, exv);
-    mlir::Value noSlice;
-    auto arrLoad = builder.create<fir::ArrayLoadOp>(
-        loc, arrType, memref, shape, noSlice, fir::getTypeParams(exv));
-    mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams();
-    mlir::Value arrLd = arrLoad.getResult();
-    // Mark the load to tell later passes it is unsafe to use this array_load
-    // shape unconditionally.
-    arrLoad->setAttr(fir::getOptionalAttrName(), builder.getUnitAttr());
-
-    // Place the array as optional on the arrayOperands stack so that its
-    // shape will only be used as a fallback to induce the implicit loop nest
-    // (that is if there is no non optional array arguments).
-    arrayOperands.push_back(
-        ArrayOperand{memref, shape, noSlice, /*mayBeAbsent=*/true});
-
-    // By value semantics.
-    auto cc = [=](IterSpace iters) -> ExtValue {
-      auto arrFetch = builder.create<fir::ArrayFetchOp>(
-          loc, eleType, arrLd, iters.iterVec(), arrLdTypeParams);
-      return fir::factory::arraySectionElementToExtendedValue(
-          builder, loc, exv, arrFetch, noSlice);
-    };
-    return {cc, isPresent, eleType};
-  }
-
-  /// Generate a continuation to pass \p expr to an OPTIONAL argument of an
-  /// elemental procedure. This is meant to handle the cases where \p expr might
-  /// be dynamically absent (i.e. when it is a POINTER, an ALLOCATABLE or an
-  /// OPTIONAL variable). If p\ expr is guaranteed to be present genarr() can
-  /// directly be called instead.
-  CC genarrForwardOptionalArgumentToCall(const Fortran::lower::SomeExpr &expr) {
-    mlir::Location loc = getLoc();
-    // Only by-value numerical and logical so far.
-    if (semant != ConstituentSemantics::RefTransparent)
-      TODO(loc, "optional arguments in user defined elemental procedures");
-
-    // Handle scalar argument case (the if-then-else is generated outside of the
-    // implicit loop nest).
-    if (expr.Rank() == 0) {
-      ExtValue optionalArg = asInquired(expr);
-      mlir::Value isPresent = genActualIsPresentTest(builder, loc, optionalArg);
-      mlir::Value elementValue =
-          fir::getBase(genOptionalValue(builder, loc, optionalArg, isPresent));
-      return [=](IterSpace iters) -> ExtValue { return elementValue; };
-    }
-
-    CC cc;
-    mlir::Value isPresent;
-    mlir::Type eleType;
-    std::tie(cc, isPresent, eleType) = genOptionalArrayFetch(expr);
-    return [=](IterSpace iters) -> ExtValue {
-      mlir::Value elementValue =
-          builder
-              .genIfOp(loc, {eleType}, isPresent,
-                       /*withElseRegion=*/true)
-              .genThen([&]() {
-                builder.create<fir::ResultOp>(loc, fir::getBase(cc(iters)));
-              })
-              .genElse([&]() {
-                mlir::Value zero =
-                    fir::factory::createZeroValue(builder, loc, eleType);
-                builder.create<fir::ResultOp>(loc, zero);
-              })
-              .getResults()[0];
-      return elementValue;
-    };
-  }
-
-  /// Reduce the rank of a array to be boxed based on the slice's operands.
-  static mlir::Type reduceRank(mlir::Type arrTy, mlir::Value slice) {
-    if (slice) {
-      auto slOp = mlir::dyn_cast<fir::SliceOp>(slice.getDefiningOp());
-      assert(slOp && "expected slice op");
-      auto seqTy = arrTy.dyn_cast<fir::SequenceType>();
-      assert(seqTy && "expected array type");
-      mlir::Operation::operand_range triples = slOp.getTriples();
-      fir::SequenceType::Shape shape;
-      // reduce the rank for each invariant dimension
-      for (unsigned i = 1, end = triples.size(); i < end; i += 3)
-        if (!mlir::isa_and_nonnull<fir::UndefOp>(triples[i].getDefiningOp()))
-          shape.push_back(fir::SequenceType::getUnknownExtent());
-      return fir::SequenceType::get(shape, seqTy.getEleTy());
-    }
-    // not sliced, so no change in rank
-    return arrTy;
-  }
-
-  CC genarr(const Fortran::evaluate::ComplexPart &x,
-            ComponentPath &components) {
-    components.reversePath.push_back(&x);
-    return genarr(x.complex(), components);
-  }
-
-  CC genarr(const Fortran::evaluate::StaticDataObject::Pointer &,
-            ComponentPath &components) {
-    TODO(getLoc(), "genarr StaticDataObject::Pointer");
-  }
-
-  /// Substrings (see 9.4.1)
-  CC genarr(const Fortran::evaluate::Substring &x, ComponentPath &components) {
-    components.substring = &x;
-    return std::visit([&](const auto &v) { return genarr(v, components); },
-                      x.parent());
-  }
-
-  /// Base case of generating an array reference,
-  CC genarr(const ExtValue &extMemref, ComponentPath &components) {
-    mlir::Location loc = getLoc();
-    mlir::Value memref = fir::getBase(extMemref);
-    mlir::Type arrTy = fir::dyn_cast_ptrOrBoxEleTy(memref.getType());
-    assert(arrTy.isa<fir::SequenceType>() && "memory ref must be an array");
-    mlir::Value shape = builder.createShape(loc, extMemref);
-    mlir::Value slice;
-    if (components.isSlice()) {
-      if (isBoxValue() && components.substring) {
-        // Append the substring operator to emboxing Op as it will become an
-        // interior adjustment (add offset, adjust LEN) to the CHARACTER value
-        // being referenced in the descriptor.
-        llvm::SmallVector<mlir::Value> substringBounds;
-        populateBounds(substringBounds, components.substring);
-        // Convert to (offset, size)
-        mlir::Type iTy = substringBounds[0].getType();
-        if (substringBounds.size() != 2) {
-          fir::CharacterType charTy =
-              fir::factory::CharacterExprHelper::getCharType(arrTy);
-          if (charTy.hasConstantLen()) {
-            mlir::IndexType idxTy = builder.getIndexType();
-            fir::CharacterType::LenType charLen = charTy.getLen();
-            mlir::Value lenValue =
-                builder.createIntegerConstant(loc, idxTy, charLen);
-            substringBounds.push_back(lenValue);
-          } else {
-            llvm::SmallVector<mlir::Value> typeparams =
-                fir::getTypeParams(extMemref);
-            substringBounds.push_back(typeparams.back());
-          }
-        }
-        // Convert the lower bound to 0-based substring.
-        mlir::Value one =
-            builder.createIntegerConstant(loc, substringBounds[0].getType(), 1);
-        substringBounds[0] =
-            builder.create<mlir::arith::SubIOp>(loc, substringBounds[0], one);
-        // Convert the upper bound to a length.
-        mlir::Value cast = builder.createConvert(loc, iTy, substringBounds[1]);
-        mlir::Value zero = builder.createIntegerConstant(loc, iTy, 0);
-        auto size =
-            builder.create<mlir::arith::SubIOp>(loc, cast, substringBounds[0]);
-        auto cmp = builder.create<mlir::arith::CmpIOp>(
-            loc, mlir::arith::CmpIPredicate::sgt, size, zero);
-        // size = MAX(upper - (lower - 1), 0)
-        substringBounds[1] =
-            builder.create<mlir::arith::SelectOp>(loc, cmp, size, zero);
-        slice = builder.create<fir::SliceOp>(loc, components.trips,
-                                             components.suffixComponents,
-                                             substringBounds);
-      } else {
-        slice = builder.createSlice(loc, extMemref, components.trips,
-                                    components.suffixComponents);
-      }
-      if (components.hasComponents()) {
-        auto seqTy = arrTy.cast<fir::SequenceType>();
-        mlir::Type eleTy =
-            fir::applyPathToType(seqTy.getEleTy(), components.suffixComponents);
-        if (!eleTy)
-          fir::emitFatalError(loc, "slicing path is ill-formed");
-        if (auto realTy = eleTy.dyn_cast<fir::RealType>())
-          eleTy = Fortran::lower::convertReal(realTy.getContext(),
-                                              realTy.getFKind());
-
-        // create the type of the projected array.
-        arrTy = fir::SequenceType::get(seqTy.getShape(), eleTy);
-        LLVM_DEBUG(llvm::dbgs()
-                   << "type of array projection from component slicing: "
-                   << eleTy << ", " << arrTy << '\n');
-      }
-    }
-    arrayOperands.push_back(ArrayOperand{memref, shape, slice});
-    if (destShape.empty())
-      destShape = getShape(arrayOperands.back());
-    if (isBoxValue()) {
-      // Semantics are a reference to a boxed array.
-      // This case just requires that an embox operation be created to box the
-      // value. The value of the box is forwarded in the continuation.
-      mlir::Type reduceTy = reduceRank(arrTy, slice);
-      auto boxTy = fir::BoxType::get(reduceTy);
-      if (components.substring) {
-        // Adjust char length to substring size.
-        fir::CharacterType charTy =
-            fir::factory::CharacterExprHelper::getCharType(reduceTy);
-        auto seqTy = reduceTy.cast<fir::SequenceType>();
-        // TODO: Use a constant for fir.char LEN if we can compute it.
-        boxTy = fir::BoxType::get(
-            fir::SequenceType::get(fir::CharacterType::getUnknownLen(
-                                       builder.getContext(), charTy.getFKind()),
-                                   seqTy.getDimension()));
-      }
-      mlir::Value embox =
-          memref.getType().isa<fir::BoxType>()
-              ? builder.create<fir::ReboxOp>(loc, boxTy, memref, shape, slice)
-                    .getResult()
-              : builder
-                    .create<fir::EmboxOp>(loc, boxTy, memref, shape, slice,
-                                          fir::getTypeParams(extMemref))
-                    .getResult();
-      return [=](IterSpace) -> ExtValue { return fir::BoxValue(embox); };
-    }
-    auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
-    if (isReferentiallyOpaque()) {
-      // Semantics are an opaque reference to an array.
-      // This case forwards a continuation that will generate the address
-      // arithmetic to the array element. This does not have copy-in/copy-out
-      // semantics. No attempt to copy the array value will be made during the
-      // interpretation of the Fortran statement.
-      mlir::Type refEleTy = builder.getRefType(eleTy);
-      return [=](IterSpace iters) -> ExtValue {
-        // ArrayCoorOp does not expect zero based indices.
-        llvm::SmallVector<mlir::Value> indices = fir::factory::originateIndices(
-            loc, builder, memref.getType(), shape, iters.iterVec());
-        mlir::Value coor = builder.create<fir::ArrayCoorOp>(
-            loc, refEleTy, memref, shape, slice, indices,
-            fir::getTypeParams(extMemref));
-        if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
-          llvm::SmallVector<mlir::Value> substringBounds;
-          populateBounds(substringBounds, components.substring);
-          if (!substringBounds.empty()) {
-            mlir::Value dstLen = fir::factory::genLenOfCharacter(
-                builder, loc, arrTy.cast<fir::SequenceType>(), memref,
-                fir::getTypeParams(extMemref), iters.iterVec(),
-                substringBounds);
-            fir::CharBoxValue dstChar(coor, dstLen);
-            return fir::factory::CharacterExprHelper{builder, loc}
-                .createSubstring(dstChar, substringBounds);
-          }
-        }
-        return fir::factory::arraySectionElementToExtendedValue(
-            builder, loc, extMemref, coor, slice);
-      };
-    }
-    auto arrLoad = builder.create<fir::ArrayLoadOp>(
-        loc, arrTy, memref, shape, slice, fir::getTypeParams(extMemref));
-    mlir::Value arrLd = arrLoad.getResult();
-    if (isProjectedCopyInCopyOut()) {
-      // Semantics are projected copy-in copy-out.
-      // The backing store of the destination of an array expression may be
-      // partially modified. These updates are recorded in FIR by forwarding a
-      // continuation that generates an `array_update` Op. The destination is
-      // always loaded at the beginning of the statement and merged at the
-      // end.
-      destination = arrLoad;
-      auto lambda = ccStoreToDest.hasValue()
-                        ? ccStoreToDest.getValue()
-                        : defaultStoreToDestination(components.substring);
-      return [=](IterSpace iters) -> ExtValue { return lambda(iters); };
-    }
-    if (isCustomCopyInCopyOut()) {
-      // Create an array_modify to get the LHS element address and indicate
-      // the assignment, the actual assignment must be implemented in
-      // ccStoreToDest.
-      destination = arrLoad;
-      return [=](IterSpace iters) -> ExtValue {
-        mlir::Value innerArg = iters.innerArgument();
-        mlir::Type resTy = innerArg.getType();
-        mlir::Type eleTy = fir::applyPathToType(resTy, iters.iterVec());
-        mlir::Type refEleTy =
-            fir::isa_ref_type(eleTy) ? eleTy : builder.getRefType(eleTy);
-        auto arrModify = builder.create<fir::ArrayModifyOp>(
-            loc, mlir::TypeRange{refEleTy, resTy}, innerArg, iters.iterVec(),
-            destination.getTypeparams());
-        return abstractArrayExtValue(arrModify.getResult(1));
-      };
-    }
-    if (isCopyInCopyOut()) {
-      // Semantics are copy-in copy-out.
-      // The continuation simply forwards the result of the `array_load` Op,
-      // which is the value of the array as it was when loaded. All data
-      // references with rank > 0 in an array expression typically have
-      // copy-in copy-out semantics.
-      return [=](IterSpace) -> ExtValue { return arrLd; };
-    }
-    mlir::Operation::operand_range arrLdTypeParams = arrLoad.getTypeparams();
-    if (isValueAttribute()) {
-      // Semantics are value attribute.
-      // Here the continuation will `array_fetch` a value from an array and
-      // then store that value in a temporary. One can thus imitate pass by
-      // value even when the call is pass by reference.
-      return [=](IterSpace iters) -> ExtValue {
-        mlir::Value base;
-        mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
-        if (isAdjustedArrayElementType(eleTy)) {
-          mlir::Type eleRefTy = builder.getRefType(eleTy);
-          base = builder.create<fir::ArrayAccessOp>(
-              loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
-        } else {
-          base = builder.create<fir::ArrayFetchOp>(
-              loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
-        }
-        mlir::Value temp = builder.createTemporary(
-            loc, base.getType(),
-            llvm::ArrayRef<mlir::NamedAttribute>{
-                Fortran::lower::getAdaptToByRefAttr(builder)});
-        builder.create<fir::StoreOp>(loc, base, temp);
-        return fir::factory::arraySectionElementToExtendedValue(
-            builder, loc, extMemref, temp, slice);
-      };
-    }
-    // In the default case, the array reference forwards an `array_fetch` or
-    // `array_access` Op in the continuation.
-    return [=](IterSpace iters) -> ExtValue {
-      mlir::Type eleTy = fir::applyPathToType(arrTy, iters.iterVec());
-      if (isAdjustedArrayElementType(eleTy)) {
-        mlir::Type eleRefTy = builder.getRefType(eleTy);
-        mlir::Value arrayOp = builder.create<fir::ArrayAccessOp>(
-            loc, eleRefTy, arrLd, iters.iterVec(), arrLdTypeParams);
-        if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
-          llvm::SmallVector<mlir::Value> substringBounds;
-          populateBounds(substringBounds, components.substring);
-          if (!substringBounds.empty()) {
-            mlir::Value dstLen = fir::factory::genLenOfCharacter(
-                builder, loc, arrLoad, iters.iterVec(), substringBounds);
-            fir::CharBoxValue dstChar(arrayOp, dstLen);
-            return fir::factory::CharacterExprHelper{builder, loc}
-                .createSubstring(dstChar, substringBounds);
-          }
-        }
-        return fir::factory::arraySectionElementToExtendedValue(
-            builder, loc, extMemref, arrayOp, slice);
-      }
-      auto arrFetch = builder.create<fir::ArrayFetchOp>(
-          loc, eleTy, arrLd, iters.iterVec(), arrLdTypeParams);
-      return fir::factory::arraySectionElementToExtendedValue(
-          builder, loc, extMemref, arrFetch, slice);
-    };
-  }
-
-private:
-  void determineShapeOfDest(const fir::ExtendedValue &lhs) {
-    destShape = fir::factory::getExtents(builder, getLoc(), lhs);
-  }
-
-  void determineShapeOfDest(const Fortran::lower::SomeExpr &lhs) {
-    if (!destShape.empty())
-      return;
-    if (explicitSpaceIsActive() && determineShapeWithSlice(lhs))
-      return;
-    mlir::Type idxTy = builder.getIndexType();
-    mlir::Location loc = getLoc();
-    if (std::optional<Fortran::evaluate::ConstantSubscripts> constantShape =
-            Fortran::evaluate::GetConstantExtents(converter.getFoldingContext(),
-                                                  lhs))
-      for (Fortran::common::ConstantSubscript extent : *constantShape)
-        destShape.push_back(builder.createIntegerConstant(loc, idxTy, extent));
-  }
-
-  bool genShapeFromDataRef(const Fortran::semantics::Symbol &x) {
-    return false;
-  }
-  bool genShapeFromDataRef(const Fortran::evaluate::CoarrayRef &) {
-    TODO(getLoc(), "coarray ref");
-    return false;
-  }
-  bool genShapeFromDataRef(const Fortran::evaluate::Component &x) {
-    return x.base().Rank() > 0 ? genShapeFromDataRef(x.base()) : false;
-  }
-  bool genShapeFromDataRef(const Fortran::evaluate::ArrayRef &x) {
-    if (x.Rank() == 0)
-      return false;
-    if (x.base().Rank() > 0)
-      if (genShapeFromDataRef(x.base()))
-        return true;
-    // x has rank and x.base did not produce a shape.
-    ExtValue exv = x.base().IsSymbol() ? asScalarRef(getFirstSym(x.base()))
-                                       : asScalarRef(x.base().GetComponent());
-    mlir::Location loc = getLoc();
-    mlir::IndexType idxTy = builder.getIndexType();
-    llvm::SmallVector<mlir::Value> definedShape =
-        fir::factory::getExtents(builder, loc, exv);
-    mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
-    for (auto ss : llvm::enumerate(x.subscript())) {
-      std::visit(Fortran::common::visitors{
-                     [&](const Fortran::evaluate::Triplet &trip) {
-                       // For a subscript of triple notation, we compute the
-                       // range of this dimension of the iteration space.
-                       auto lo = [&]() {
-                         if (auto optLo = trip.lower())
-                           return fir::getBase(asScalar(*optLo));
-                         return getLBound(exv, ss.index(), one);
-                       }();
-                       auto hi = [&]() {
-                         if (auto optHi = trip.upper())
-                           return fir::getBase(asScalar(*optHi));
-                         return getUBound(exv, ss.index(), one);
-                       }();
-                       auto step = builder.createConvert(
-                           loc, idxTy, fir::getBase(asScalar(trip.stride())));
-                       auto extent = builder.genExtentFromTriplet(loc, lo, hi,
-                                                                  step, idxTy);
-                       destShape.push_back(extent);
-                     },
-                     [&](auto) {}},
-                 ss.value().u);
-    }
-    return true;
-  }
-  bool genShapeFromDataRef(const Fortran::evaluate::NamedEntity &x) {
-    if (x.IsSymbol())
-      return genShapeFromDataRef(getFirstSym(x));
-    return genShapeFromDataRef(x.GetComponent());
-  }
-  bool genShapeFromDataRef(const Fortran::evaluate::DataRef &x) {
-    return std::visit([&](const auto &v) { return genShapeFromDataRef(v); },
-                      x.u);
-  }
-
-  /// When in an explicit space, the ranked component must be evaluated to
-  /// determine the actual number of iterations when slicing triples are
-  /// present. Lower these expressions here.
-  bool determineShapeWithSlice(const Fortran::lower::SomeExpr &lhs) {
-    LLVM_DEBUG(Fortran::lower::DumpEvaluateExpr::dump(
-        llvm::dbgs() << "determine shape of:\n", lhs));
-    // FIXME: We may not want to use ExtractDataRef here since it doesn't deal
-    // with substrings, etc.
-    std::optional<Fortran::evaluate::DataRef> dref =
-        Fortran::evaluate::ExtractDataRef(lhs);
-    return dref.has_value() ? genShapeFromDataRef(*dref) : false;
-  }
-
-  ExtValue lowerArrayExpression(const Fortran::lower::SomeExpr &exp) {
-    mlir::Type resTy = converter.genType(exp);
-    return std::visit(
-        [&](const auto &e) { return lowerArrayExpression(genarr(e), resTy); },
-        exp.u);
-  }
-  ExtValue lowerArrayExpression(const ExtValue &exv) {
-    assert(!explicitSpace);
-    mlir::Type resTy = fir::unwrapPassByRefType(fir::getBase(exv).getType());
-    return lowerArrayExpression(genarr(exv), resTy);
-  }
-
-  void populateBounds(llvm::SmallVectorImpl<mlir::Value> &bounds,
-                      const Fortran::evaluate::Substring *substring) {
-    if (!substring)
-      return;
-    bounds.push_back(fir::getBase(asScalar(substring->lower())));
-    if (auto upper = substring->upper())
-      bounds.push_back(fir::getBase(asScalar(*upper)));
-  }
-
-  /// Default store to destination implementation.
-  /// This implements the default case, which is to assign the value in
-  /// `iters.element` into the destination array, `iters.innerArgument`. Handles
-  /// by value and by reference assignment.
-  CC defaultStoreToDestination(const Fortran::evaluate::Substring *substring) {
-    return [=](IterSpace iterSpace) -> ExtValue {
-      mlir::Location loc = getLoc();
-      mlir::Value innerArg = iterSpace.innerArgument();
-      fir::ExtendedValue exv = iterSpace.elementExv();
-      mlir::Type arrTy = innerArg.getType();
-      mlir::Type eleTy = fir::applyPathToType(arrTy, iterSpace.iterVec());
-      if (isAdjustedArrayElementType(eleTy)) {
-        // The elemental update is in the memref domain. Under this semantics,
-        // we must always copy the computed new element from its location in
-        // memory into the destination array.
-        mlir::Type resRefTy = builder.getRefType(eleTy);
-        // Get a reference to the array element to be amended.
-        auto arrayOp = builder.create<fir::ArrayAccessOp>(
-            loc, resRefTy, innerArg, iterSpace.iterVec(),
-            destination.getTypeparams());
-        if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
-          llvm::SmallVector<mlir::Value> substringBounds;
-          populateBounds(substringBounds, substring);
-          mlir::Value dstLen = fir::factory::genLenOfCharacter(
-              builder, loc, destination, iterSpace.iterVec(), substringBounds);
-          fir::ArrayAmendOp amend = createCharArrayAmend(
-              loc, builder, arrayOp, dstLen, exv, innerArg, substringBounds);
-          return abstractArrayExtValue(amend, dstLen);
-        }
-        if (fir::isa_derived(eleTy)) {
-          fir::ArrayAmendOp amend = createDerivedArrayAmend(
-              loc, destination, builder, arrayOp, exv, eleTy, innerArg);
-          return abstractArrayExtValue(amend /*FIXME: typeparams?*/);
-        }
-        assert(eleTy.isa<fir::SequenceType>() && "must be an array");
-        TODO(loc, "array (as element) assignment");
-      }
-      // By value semantics. The element is being assigned by value.
-      mlir::Value ele = builder.createConvert(loc, eleTy, fir::getBase(exv));
-      auto update = builder.create<fir::ArrayUpdateOp>(
-          loc, arrTy, innerArg, ele, iterSpace.iterVec(),
-          destination.getTypeparams());
-      return abstractArrayExtValue(update);
-    };
-  }
-
-  /// For an elemental array expression.
-  ///   1. Lower the scalars and array loads.
-  ///   2. Create the iteration space.
-  ///   3. Create the element-by-element computation in the loop.
-  ///   4. Return the resulting array value.
-  /// If no destination was set in the array context, a temporary of
-  /// \p resultTy will be created to hold the evaluated expression.
-  /// Otherwise, \p resultTy is ignored and the expression is evaluated
-  /// in the destination. \p f is a continuation built from an
-  /// evaluate::Expr or an ExtendedValue.
-  ExtValue lowerArrayExpression(CC f, mlir::Type resultTy) {
-    mlir::Location loc = getLoc();
-    auto [iterSpace, insPt] = genIterSpace(resultTy);
-    auto exv = f(iterSpace);
-    iterSpace.setElement(std::move(exv));
-    auto lambda = ccStoreToDest.hasValue()
-                      ? ccStoreToDest.getValue()
-                      : defaultStoreToDestination(/*substring=*/nullptr);
-    mlir::Value updVal = fir::getBase(lambda(iterSpace));
-    finalizeElementCtx();
-    builder.create<fir::ResultOp>(loc, updVal);
-    builder.restoreInsertionPoint(insPt);
-    return abstractArrayExtValue(iterSpace.outerResult());
-  }
-
-  /// Compute the shape of a slice.
-  llvm::SmallVector<mlir::Value> computeSliceShape(mlir::Value slice) {
-    llvm::SmallVector<mlir::Value> slicedShape;
-    auto slOp = mlir::cast<fir::SliceOp>(slice.getDefiningOp());
-    mlir::Operation::operand_range triples = slOp.getTriples();
-    mlir::IndexType idxTy = builder.getIndexType();
-    mlir::Location loc = getLoc();
-    for (unsigned i = 0, end = triples.size(); i < end; i += 3) {
-      if (!mlir::isa_and_nonnull<fir::UndefOp>(
-              triples[i + 1].getDefiningOp())) {
-        // (..., lb:ub:step, ...) case:  extent = max((ub-lb+step)/step, 0)
-        // See Fortran 2018 9.5.3.3.2 section for more details.
-        mlir::Value res = builder.genExtentFromTriplet(
-            loc, triples[i], triples[i + 1], triples[i + 2], idxTy);
-        slicedShape.emplace_back(res);
-      } else {
-        // do nothing. `..., i, ...` case, so dimension is dropped.
-      }
-    }
-    return slicedShape;
-  }
-
-  /// Get the shape from an ArrayOperand. The shape of the array is adjusted if
-  /// the array was sliced.
-  llvm::SmallVector<mlir::Value> getShape(ArrayOperand array) {
-    if (array.slice)
-      return computeSliceShape(array.slice);
-    if (array.memref.getType().isa<fir::BoxType>())
-      return fir::factory::readExtents(builder, getLoc(),
-                                       fir::BoxValue{array.memref});
-    std::vector<mlir::Value, std::allocator<mlir::Value>> extents =
-        fir::factory::getExtents(array.shape);
-    return {extents.begin(), extents.end()};
-  }
-
-  /// Get the shape from an ArrayLoad.
-  llvm::SmallVector<mlir::Value> getShape(fir::ArrayLoadOp arrayLoad) {
-    return getShape(ArrayOperand{arrayLoad.getMemref(), arrayLoad.getShape(),
-                                 arrayLoad.getSlice()});
-  }
-
-  /// Returns the first array operand that may not be absent. If all
-  /// array operands may be absent, return the first one.
-  const ArrayOperand &getInducingShapeArrayOperand() const {
-    assert(!arrayOperands.empty());
-    for (const ArrayOperand &op : arrayOperands)
-      if (!op.mayBeAbsent)
-        return op;
-    // If all arrays operand appears in optional position, then none of them
-    // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the
-    // first operands.
-    // TODO: There is an opportunity to add a runtime check here that
-    // this array is present as required.
-    return arrayOperands[0];
-  }
-
-  /// Generate the shape of the iteration space over the array expression. The
-  /// iteration space may be implicit, explicit, or both. If it is implied it is
-  /// based on the destination and operand array loads, or an optional
-  /// Fortran::evaluate::Shape from the front end. If the shape is explicit,
-  /// this returns any implicit shape component, if it exists.
-  llvm::SmallVector<mlir::Value> genIterationShape() {
-    // Use the precomputed destination shape.
-    if (!destShape.empty())
-      return destShape;
-    // Otherwise, use the destination's shape.
-    if (destination)
-      return getShape(destination);
-    // Otherwise, use the first ArrayLoad operand shape.
-    if (!arrayOperands.empty())
-      return getShape(getInducingShapeArrayOperand());
-    fir::emitFatalError(getLoc(),
-                        "failed to compute the array expression shape");
-  }
-
   explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
                              Fortran::lower::StatementContext &stmtCtx,
                              Fortran::lower::SymMap &symMap)
       : converter{converter}, builder{converter.getFirOpBuilder()},
         stmtCtx{stmtCtx}, symMap{symMap} {}
 
   explicit ArrayExprLowering(Fortran::lower::AbstractConverter &converter,
                              Fortran::lower::StatementContext &stmtCtx,

   /// Array appears in a lhs (or temp) context such that a projected,
   /// discontiguous subspace of the array is assigned after the rhs is fully
   /// evaluated. That is, the rhs array value is merged into a section of the
   /// lhs array.
   inline bool isProjectedCopyInCopyOut() {
     return semant == ConstituentSemantics::ProjectedCopyInCopyOut;
   }
 
+  // ???: Do we still need this?
   inline bool isCustomCopyInCopyOut() {
     return semant == ConstituentSemantics::CustomCopyInCopyOut;
   }
 
   /// Array appears in a context where it must be boxed.
   inline bool isBoxValue() { return semant == ConstituentSemantics::BoxValue; }
 
   /// Array appears in a context where differences in the memory reference can
return ScalarExprLowering{loc, converter, symMap, stmtCtx,
       .genval(expr);
 }
 
 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);
+  return ScalarExprLowering(loc, converter, symMap, stmtCtx).gen(expr);
 }
 
 fir::ExtendedValue Fortran::lower::createInitializerAddress(
     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');
   InitializerData init;
   return ScalarExprLowering(loc, converter, symMap, stmtCtx, &init).gen(expr);
 }
 
+void Fortran::lower::createSomeArrayAssignment(
+    Fortran::lower::AbstractConverter &converter,
+    const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+  LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';
+             rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
+  ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
+}
+
+void Fortran::lower::createSomeArrayAssignment(
+    Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
+    const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap,
+    Fortran::lower::StatementContext &stmtCtx) {
+  LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
+             rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
+  ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
+}
+void Fortran::lower::createSomeArrayAssignment(
+    Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
+    const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap,
+    Fortran::lower::StatementContext &stmtCtx) {
+  LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
+             llvm::dbgs() << "assign expression: " << rhs << '\n';);
+  ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
+}
+
+void Fortran::lower::createAnyMaskedArrayAssignment(
+    Fortran::lower::AbstractConverter &converter,
+    const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
+    Fortran::lower::ExplicitIterSpace &explicitSpace,
+    Fortran::lower::ImplicitIterSpace &implicitSpace,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+  LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';
+             rhs.AsFortran(llvm::dbgs() << "assign expression: ")
+             << " given the explicit iteration space:\n"
+             << explicitSpace << "\n and implied mask conditions:\n"
+             << implicitSpace << '\n';);
+  ArrayExprLowering::lowerAnyMaskedArrayAssignment(
+      converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
+}
+
+void Fortran::lower::createAllocatableArrayAssignment(
+    Fortran::lower::AbstractConverter &converter,
+    const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
+    Fortran::lower::ExplicitIterSpace &explicitSpace,
+    Fortran::lower::ImplicitIterSpace &implicitSpace,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+  LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n';
+             rhs.AsFortran(llvm::dbgs() << "assign expression: ")
+             << " given the explicit iteration space:\n"
+             << explicitSpace << "\n and implied mask conditions:\n"
+             << implicitSpace << '\n';);
+  ArrayExprLowering::lowerAllocatableArrayAssignment(
+      converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
+}
+
+fir::ExtendedValue Fortran::lower::createSomeArrayTempValue(
+    Fortran::lower::AbstractConverter &converter,
+    const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
+    Fortran::lower::StatementContext &stmtCtx) {
+  LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n');
+  return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx,
+                                                    expr);
+}
+
+void Fortran::lower::createLazyArrayTempValue(
+    Fortran::lower::AbstractConverter &converter,
+    const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+  LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n');
+  ArrayExprLowering::lowerLazyArrayExpression(converter, symMap, stmtCtx, expr,
+                                              raggedHeader);
+}
+
 fir::ExtendedValue
 Fortran::lower::createSomeArrayBox(Fortran::lower::AbstractConverter &converter,
                                    const Fortran::lower::SomeExpr &expr,
                                    Fortran::lower::SymMap &symMap,
                                    Fortran::lower::StatementContext &stmtCtx) {
   LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "box designator: ") << '\n');
   return ArrayExprLowering::lowerBoxedArrayExpression(converter, symMap,
                                                       stmtCtx, expr);

 }
 template <>
 fir::ArrayLoadOp
 genArrayLoad(mlir::Location loc, Fortran::lower::AbstractConverter &converter,
              fir::FirOpBuilder &builder, const Fortran::evaluate::ArrayRef *x,
              Fortran::lower::SymMap &symMap,
              Fortran::lower::StatementContext &stmtCtx) {
   if (x->base().IsSymbol())
-    return genArrayLoad(loc, converter, builder, &x->base().GetLastSymbol(),
-                        symMap, stmtCtx);
+    return genArrayLoad(loc, converter, builder, &getLastSym(x->base()), symMap,
+                        stmtCtx);
   return genArrayLoad(loc, converter, builder, &x->base().GetComponent(),
                       symMap, stmtCtx);
 }
 
 void Fortran::lower::createArrayLoads(
     Fortran::lower::AbstractConverter &converter,
     Fortran::lower::ExplicitIterSpace &esp, Fortran::lower::SymMap &symMap) {
   std::size_t counter = esp.getCounter();
void Fortran::lower::createArrayMergeStores(
   }
   esp.initialArgs.clear();
   esp.innerArgs.clear();
   esp.outerLoop = llvm::None;
   esp.resetBindings();
   esp.incrementCounter();
 }
 
-void Fortran::lower::createSomeArrayAssignment(
-    Fortran::lower::AbstractConverter &converter,
-    const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
-    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
-  LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';
-             rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
-  ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
-}
-
-void Fortran::lower::createSomeArrayAssignment(
-    Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
-    const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap,
-    Fortran::lower::StatementContext &stmtCtx) {
-  LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
-             rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
-  ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
-}
-
-void Fortran::lower::createSomeArrayAssignment(
-    Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
-    const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap,
-    Fortran::lower::StatementContext &stmtCtx) {
-  LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
-             llvm::dbgs() << "assign expression: " << rhs << '\n';);
-  ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
-}
-
-void Fortran::lower::createAnyMaskedArrayAssignment(
-    Fortran::lower::AbstractConverter &converter,
-    const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
-    Fortran::lower::ExplicitIterSpace &explicitSpace,
-    Fortran::lower::ImplicitIterSpace &implicitSpace,
-    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
-  LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';
-             rhs.AsFortran(llvm::dbgs() << "assign expression: ")
-             << " given the explicit iteration space:\n"
-             << explicitSpace << "\n and implied mask conditions:\n"
-             << implicitSpace << '\n';);
-  ArrayExprLowering::lowerAnyMaskedArrayAssignment(
-      converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
-}
-
-void Fortran::lower::createAllocatableArrayAssignment(
-    Fortran::lower::AbstractConverter &converter,
-    const Fortran::lower::SomeExpr &lhs, const Fortran::lower::SomeExpr &rhs,
-    Fortran::lower::ExplicitIterSpace &explicitSpace,
-    Fortran::lower::ImplicitIterSpace &implicitSpace,
-    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
-  LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "defining array: ") << '\n';
-             rhs.AsFortran(llvm::dbgs() << "assign expression: ")
-             << " given the explicit iteration space:\n"
-             << explicitSpace << "\n and implied mask conditions:\n"
-             << implicitSpace << '\n';);
-  ArrayExprLowering::lowerAllocatableArrayAssignment(
-      converter, symMap, stmtCtx, lhs, rhs, explicitSpace, implicitSpace);
-}
-
-fir::ExtendedValue Fortran::lower::createSomeArrayTempValue(
-    Fortran::lower::AbstractConverter &converter,
-    const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
-    Fortran::lower::StatementContext &stmtCtx) {
-  LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n');
-  return ArrayExprLowering::lowerNewArrayExpression(converter, symMap, stmtCtx,
-                                                    expr);
-}
-
-void Fortran::lower::createLazyArrayTempValue(
-    Fortran::lower::AbstractConverter &converter,
-    const Fortran::lower::SomeExpr &expr, mlir::Value raggedHeader,
-    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
-  LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "array value: ") << '\n');
-  ArrayExprLowering::lowerLazyArrayExpression(converter, symMap, stmtCtx, expr,
-                                              raggedHeader);
-}
-
 mlir::Value Fortran::lower::genMaxWithZero(fir::FirOpBuilder &builder,
                                            mlir::Location loc,
                                            mlir::Value value) {
   mlir::Value zero = builder.createIntegerConstant(loc, value.getType(), 0);
   if (mlir::Operation *definingOp = value.getDefiningOp())
     if (auto cst = mlir::dyn_cast<mlir::arith::ConstantOp>(definingOp))
       if (auto intAttr = cst.getValue().dyn_cast<mlir::IntegerAttr>())
         return intAttr.getInt() < 0 ? zero : value;
   return Fortran::lower::genMax(builder, loc,
                                 llvm::SmallVector<mlir::Value>{value, zero});
 }

flang/lib/Lower/ConvertVariable.cpp

lowerExplicitCharLen(Fortran::lower::AbstractConverter &converter,
                      Fortran::lower::StatementContext &stmtCtx) {
   if (!box.isChar())
     return mlir::Value{};
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   mlir::Type lenTy = builder.getCharacterLengthType();
   if (llvm::Optional<int64_t> len = box.getCharLenConst())
     return builder.createIntegerConstant(loc, lenTy, *len);
   if (llvm::Optional<Fortran::lower::SomeExpr> lenExpr = box.getCharLenExpr())
-    return genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx);
+    // If the length expression is negative, the length is zero. See F2018
+    // 7.4.4.2 point 5.
+    return Fortran::lower::genMaxWithZero(
+        builder, loc,
+        genScalarValue(converter, loc, *lenExpr, symMap, stmtCtx));
   return mlir::Value{};
 }
 
 /// 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,

flang/lib/Lower/IntrinsicCall.cpp

mlir::Value Fortran::lower::genMax(fir::FirOpBuilder &builder,
                                    mlir::Location loc,
                                    llvm::ArrayRef<mlir::Value> args) {
   assert(args.size() > 0 && "max requires at least one argument");
   return IntrinsicLibrary{builder, loc}
       .genExtremum<Extremum::Max, ExtremumBehavior::MinMaxss>(args[0].getType(),
                                                               args);
 }
 
+mlir::Value Fortran::lower::genMin(fir::FirOpBuilder &builder,
+                                   mlir::Location loc,
+                                   llvm::ArrayRef<mlir::Value> args) {
+  assert(args.size() > 0 && "min requires at least one argument");
+  return IntrinsicLibrary{builder, loc}
+      .genExtremum<Extremum::Min, ExtremumBehavior::MinMaxss>(args[0].getType(),
+                                                              args);
+}
+
 mlir::Value Fortran::lower::genPow(fir::FirOpBuilder &builder,
                                    mlir::Location loc, mlir::Type type,
                                    mlir::Value x, mlir::Value y) {
   return IntrinsicLibrary{builder, loc}.genRuntimeCall("pow", type, {x, y});
 }
 
 mlir::SymbolRefAttr Fortran::lower::getUnrestrictedIntrinsicSymbolRefAttr(
     fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
     mlir::FunctionType signature) {
   return IntrinsicLibrary{builder, loc}.getUnrestrictedIntrinsicSymbolRefAttr(
       name, signature);
 }

flang/lib/Optimizer/Builder/Character.cpp

 //===-- Character.cpp -----------------------------------------------------===//
 //
 // 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/Character.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/DoLoopHelper.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "llvm/Support/Debug.h"
 #include <optional>
 
 #define DEBUG_TYPE "flang-lower-character"
 
-using namespace mlir;
-
 //===----------------------------------------------------------------------===//
 // CharacterExprHelper implementation
 //===----------------------------------------------------------------------===//
 
-/// Unwrap base fir.char<kind,len> type.
-static fir::CharacterType recoverCharacterType(mlir::Type type) {
+/// Unwrap all the ref and box types and return the inner element type.
+static mlir::Type unwrapBoxAndRef(mlir::Type type) {
   if (auto boxType = type.dyn_cast<fir::BoxCharType>())
     return boxType.getEleTy();
   while (true) {
     type = fir::unwrapRefType(type);
     if (auto boxTy = type.dyn_cast<fir::BoxType>())
       type = boxTy.getEleTy();
     else
       break;
   }
-  return fir::unwrapSequenceType(type).cast<fir::CharacterType>();
+  return type;
+}
+
+/// Unwrap base fir.char<kind,len> type.
+static fir::CharacterType recoverCharacterType(mlir::Type type) {
+  type = fir::unwrapSequenceType(unwrapBoxAndRef(type));
+  if (auto charTy = type.dyn_cast<fir::CharacterType>())
+    return charTy;
+  llvm::report_fatal_error("expected a character type");
+}
+
+bool fir::factory::CharacterExprHelper::isCharacterScalar(mlir::Type type) {
+  type = unwrapBoxAndRef(type);
+  return !type.isa<fir::SequenceType>() && fir::isa_char(type);
+}
+
+bool fir::factory::CharacterExprHelper::isArray(mlir::Type type) {
+  type = unwrapBoxAndRef(type);
+  if (auto seqTy = type.dyn_cast<fir::SequenceType>())
+    return fir::isa_char(seqTy.getEleTy());
+  return false;
 }
 
-/// Get fir.char<kind> type with the same kind as inside str.
 fir::CharacterType
 fir::factory::CharacterExprHelper::getCharacterType(mlir::Type type) {
   assert(isCharacterScalar(type) && "expected scalar character");
   return recoverCharacterType(type);
 }
 
 fir::CharacterType
 fir::factory::CharacterExprHelper::getCharType(mlir::Type type) {
fir::factory::CharacterExprHelper::toExtendedValue(mlir::Value character,
   if (auto charTy = type.dyn_cast<fir::CharacterType>()) {
     if (!resultLen && charTy.getLen() != fir::CharacterType::unknownLen())
       resultLen = builder.createIntegerConstant(loc, lenType, charTy.getLen());
   } else if (auto boxCharType = type.dyn_cast<fir::BoxCharType>()) {
     auto refType = builder.getRefType(boxCharType.getEleTy());
     // If the embox is accessible, use its operand to avoid filling
     // the generated fir with embox/unbox.
     mlir::Value boxCharLen;
-    if (auto *definingOp = character.getDefiningOp()) {
-      if (auto box = dyn_cast<fir::EmboxCharOp>(definingOp)) {
+    if (auto definingOp = character.getDefiningOp()) {
+      if (auto box = mlir::dyn_cast<fir::EmboxCharOp>(definingOp)) {
         base = box.getMemref();
         boxCharLen = box.getLen();
       }
     }
     if (!boxCharLen) {
       auto unboxed =
           builder.create<fir::UnboxCharOp>(loc, refType, lenType, character);
       base = builder.createConvert(loc, refType, unboxed.getResult(0));
fir::CharBoxValue fir::factory::CharacterExprHelper::toScalarCharacter(
   if (box.getBuffer().getType().isa<fir::PointerType>())
     TODO(loc, "concatenating non contiguous character array into a scalar");
 
   // TODO: add a fast path multiplying new length at compile time if the info is
   // in the array type.
   auto lenType = builder.getCharacterLengthType();
   auto len = builder.createConvert(loc, lenType, box.getLen());
   for (auto extent : box.getExtents())
-    len = builder.create<arith::MulIOp>(
+    len = builder.create<mlir::arith::MulIOp>(
         loc, len, builder.createConvert(loc, lenType, extent));
 
   // TODO: typeLen can be improved in compiled constant cases
   // TODO: allow bare fir.array<> (no ref) conversion here ?
   auto typeLen = fir::CharacterType::unknownLen();
   auto kind = recoverCharacterType(box.getBuffer().getType()).getFKind();
   auto charTy = fir::CharacterType::get(builder.getContext(), kind, typeLen);
   auto type = fir::ReferenceType::get(charTy);
mlir::Value fir::factory::CharacterExprHelper::getCharBoxBuffer(
   if (fir::isa_char(buff.getType())) {
     auto newBuff = builder.create<fir::AllocaOp>(loc, buff.getType());
     builder.create<fir::StoreOp>(loc, buff, newBuff);
     return newBuff;
   }
   return buff;
 }
 
-/// Get the LLVM intrinsic for `memcpy`. Use the 64 bit version.
-mlir::FuncOp fir::factory::getLlvmMemcpy(fir::FirOpBuilder &builder) {
-  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
-  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
-                                        builder.getI1Type()};
-  auto memcpyTy =
-      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
-  return builder.addNamedFunction(builder.getUnknownLoc(),
-                                  "llvm.memcpy.p0i8.p0i8.i64", memcpyTy);
-}
-
-/// Get the LLVM intrinsic for `memmove`. Use the 64 bit version.
-mlir::FuncOp fir::factory::getLlvmMemmove(fir::FirOpBuilder &builder) {
-  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
-  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
-                                        builder.getI1Type()};
-  auto memmoveTy =
-      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
-  return builder.addNamedFunction(builder.getUnknownLoc(),
-                                  "llvm.memmove.p0i8.p0i8.i64", memmoveTy);
-}
-
-/// Get the LLVM intrinsic for `memset`. Use the 64 bit version.
-mlir::FuncOp fir::factory::getLlvmMemset(fir::FirOpBuilder &builder) {
-  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
-  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
-                                        builder.getI1Type()};
-  auto memsetTy =
-      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
-  return builder.addNamedFunction(builder.getUnknownLoc(),
-                                  "llvm.memset.p0i8.p0i8.i64", memsetTy);
-}
-
-/// Get the standard `realloc` function.
-mlir::FuncOp fir::factory::getRealloc(fir::FirOpBuilder &builder) {
-  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
-  llvm::SmallVector<mlir::Type> args = {ptrTy, builder.getI64Type()};
-  auto reallocTy = mlir::FunctionType::get(builder.getContext(), args, {ptrTy});
-  return builder.addNamedFunction(builder.getUnknownLoc(), "realloc",
-                                  reallocTy);
-}
-
 /// Create a loop to copy `count` characters from `src` to `dest`. Note that the
 /// KIND indicates the number of bits in a code point. (ASCII, UCS-2, or UCS-4.)
 void fir::factory::CharacterExprHelper::createCopy(
     const fir::CharBoxValue &dest, const fir::CharBoxValue &src,
     mlir::Value count) {
   auto fromBuff = getCharBoxBuffer(src);
   auto toBuff = getCharBoxBuffer(dest);
   LLVM_DEBUG(llvm::dbgs() << "create char copy from: "; src.dump();
              llvm::dbgs() << " to: "; dest.dump();
              llvm::dbgs() << " count: " << count << '\n');
   auto kind = getCharacterKind(src.getBuffer().getType());
   // If the src and dest are the same KIND, then use memmove to move the bits.
   // We don't have to worry about overlapping ranges with memmove.
   if (getCharacterKind(dest.getBuffer().getType()) == kind) {
     auto bytes = builder.getKindMap().getCharacterBitsize(kind) / 8;
     auto i64Ty = builder.getI64Type();
     auto kindBytes = builder.createIntegerConstant(loc, i64Ty, bytes);
     auto castCount = builder.createConvert(loc, i64Ty, count);
-    auto totalBytes = builder.create<arith::MulIOp>(loc, kindBytes, castCount);
+    auto totalBytes =
+        builder.create<mlir::arith::MulIOp>(loc, kindBytes, castCount);
     auto notVolatile = builder.createBool(loc, false);
     auto memmv = getLlvmMemmove(builder);
     auto argTys = memmv.getFunctionType().getInputs();
     auto toPtr = builder.createConvert(loc, argTys[0], toBuff);
     auto fromPtr = builder.createConvert(loc, argTys[1], fromBuff);
     builder.create<fir::CallOp>(
         loc, memmv, mlir::ValueRange{toPtr, fromPtr, totalBytes, notVolatile});
     return;
if (fir::isa_ref_type(val.getType()))
     val = builder.create<fir::LoadOp>(loc, val);
   val = builder.createConvert(loc, toTy, val);
   builder.create<fir::StoreOp>(loc, val, addr);
 }
 
 /// Returns the minimum of integer mlir::Value \p a and \b.
 mlir::Value genMin(fir::FirOpBuilder &builder, mlir::Location loc,
                    mlir::Value a, mlir::Value b) {
-  auto cmp =
-      builder.create<arith::CmpIOp>(loc, arith::CmpIPredicate::slt, a, b);
+  auto cmp = builder.create<mlir::arith::CmpIOp>(
+      loc, mlir::arith::CmpIPredicate::slt, a, b);
   return builder.create<mlir::arith::SelectOp>(loc, cmp, a, b);
 }
 
 void fir::factory::CharacterExprHelper::createAssign(
     const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) {
   auto rhsCstLen = getCompileTimeLength(rhs);
   auto lhsCstLen = getCompileTimeLength(lhs);
   bool compileTimeSameLength =
void fir::factory::CharacterExprHelper::createAssign(
   }
 
   // Actual copy
   createCopy(lhs, rhs, copyCount);
 
   // Pad if needed.
   if (!compileTimeSameLength) {
     auto one = builder.createIntegerConstant(loc, lhs.getLen().getType(), 1);
-    auto maxPadding = builder.create<arith::SubIOp>(loc, lhs.getLen(), one);
+    auto maxPadding =
+        builder.create<mlir::arith::SubIOp>(loc, lhs.getLen(), one);
     createPadding(lhs, copyCount, maxPadding);
   }
 }
 
 fir::CharBoxValue fir::factory::CharacterExprHelper::createConcatenate(
     const fir::CharBoxValue &lhs, const fir::CharBoxValue &rhs) {
   auto lhsLen = builder.createConvert(loc, builder.getCharacterLengthType(),
                                       lhs.getLen());
   auto rhsLen = builder.createConvert(loc, builder.getCharacterLengthType(),
                                       rhs.getLen());
-  mlir::Value len = builder.create<arith::AddIOp>(loc, lhsLen, rhsLen);
+  mlir::Value len = builder.create<mlir::arith::AddIOp>(loc, lhsLen, rhsLen);
   auto temp = createCharacterTemp(getCharacterType(rhs), len);
   createCopy(temp, lhs, lhsLen);
   auto one = builder.createIntegerConstant(loc, len.getType(), 1);
-  auto upperBound = builder.create<arith::SubIOp>(loc, len, one);
+  auto upperBound = builder.create<mlir::arith::SubIOp>(loc, len, one);
   auto lhsLenIdx = builder.createConvert(loc, builder.getIndexType(), lhsLen);
   auto fromBuff = getCharBoxBuffer(rhs);
   auto toBuff = getCharBoxBuffer(temp);
   fir::factory::DoLoopHelper{builder, loc}.createLoop(
       lhsLenIdx, upperBound, one,
       [&](fir::FirOpBuilder &bldr, mlir::Value index) {
-        auto rhsIndex = bldr.create<arith::SubIOp>(loc, index, lhsLenIdx);
+        auto rhsIndex = bldr.create<mlir::arith::SubIOp>(loc, index, lhsLenIdx);
         auto charVal = createLoadCharAt(fromBuff, rhsIndex);
         createStoreCharAt(toBuff, index, charVal);
       });
   return temp;
 }
 
 fir::CharBoxValue fir::factory::CharacterExprHelper::createSubstring(
     const fir::CharBoxValue &box, llvm::ArrayRef<mlir::Value> bounds) {
   // Constant need to be materialize in memory to use fir.coordinate_of.
   auto nbounds = bounds.size();
   if (nbounds < 1 || nbounds > 2) {
     mlir::emitError(loc, "Incorrect number of bounds in substring");
     return {mlir::Value{}, mlir::Value{}};
   }
   mlir::SmallVector<mlir::Value> castBounds;
   // Convert bounds to length type to do safe arithmetic on it.
   for (auto bound : bounds)
     castBounds.push_back(
         builder.createConvert(loc, builder.getCharacterLengthType(), bound));
   auto lowerBound = castBounds[0];
   // FIR CoordinateOp is zero based but Fortran substring are one based.
   auto one = builder.createIntegerConstant(loc, lowerBound.getType(), 1);
-  auto offset = builder.create<arith::SubIOp>(loc, lowerBound, one).getResult();
+  auto offset =
+      builder.create<mlir::arith::SubIOp>(loc, lowerBound, one).getResult();
   auto addr = createElementAddr(box.getBuffer(), offset);
   auto kind = getCharacterKind(box.getBuffer().getType());
   auto charTy = fir::CharacterType::getUnknownLen(builder.getContext(), kind);
   auto resultType = builder.getRefType(charTy);
   auto substringRef = builder.createConvert(loc, resultType, addr);
 
   // Compute the length.
   mlir::Value substringLen;
   if (nbounds < 2) {
     substringLen =
-        builder.create<arith::SubIOp>(loc, box.getLen(), castBounds[0]);
+        builder.create<mlir::arith::SubIOp>(loc, box.getLen(), castBounds[0]);
   } else {
     substringLen =
-        builder.create<arith::SubIOp>(loc, castBounds[1], castBounds[0]);
+        builder.create<mlir::arith::SubIOp>(loc, castBounds[1], castBounds[0]);
   }
-  substringLen = builder.create<arith::AddIOp>(loc, substringLen, one);
+  substringLen = builder.create<mlir::arith::AddIOp>(loc, substringLen, one);
 
   // Set length to zero if bounds were reversed (Fortran 2018 9.4.1)
   auto zero = builder.createIntegerConstant(loc, substringLen.getType(), 0);
-  auto cdt = builder.create<arith::CmpIOp>(loc, arith::CmpIPredicate::slt,
-                                           substringLen, zero);
+  auto cdt = builder.create<mlir::arith::CmpIOp>(
+      loc, mlir::arith::CmpIPredicate::slt, substringLen, zero);
   substringLen =
       builder.create<mlir::arith::SelectOp>(loc, cdt, zero, substringLen);
 
   return {substringRef, substringLen};
 }
 
 mlir::Value
 fir::factory::CharacterExprHelper::createLenTrim(const fir::CharBoxValue &str) {
   // Note: Runtime for LEN_TRIM should also be available at some
   // point. For now use an inlined implementation.
   auto indexType = builder.getIndexType();
   auto len = builder.createConvert(loc, indexType, str.getLen());
   auto one = builder.createIntegerConstant(loc, indexType, 1);
   auto minusOne = builder.createIntegerConstant(loc, indexType, -1);
   auto zero = builder.createIntegerConstant(loc, indexType, 0);
   auto trueVal = builder.createIntegerConstant(loc, builder.getI1Type(), 1);
   auto blank = createBlankConstantCode(getCharacterType(str));
-  mlir::Value lastChar = builder.create<arith::SubIOp>(loc, len, one);
+  mlir::Value lastChar = builder.create<mlir::arith::SubIOp>(loc, len, one);
 
   auto iterWhile =
       builder.create<fir::IterWhileOp>(loc, lastChar, zero, minusOne, trueVal,
                                        /*returnFinalCount=*/false, lastChar);
   auto insPt = builder.saveInsertionPoint();
   builder.setInsertionPointToStart(iterWhile.getBody());
   auto index = iterWhile.getInductionVar();
   // Look for first non-blank from the right of the character.
   auto fromBuff = getCharBoxBuffer(str);
   auto elemAddr = createElementAddr(fromBuff, index);
   auto codeAddr =
       builder.createConvert(loc, builder.getRefType(blank.getType()), elemAddr);
   auto c = builder.create<fir::LoadOp>(loc, codeAddr);
-  auto isBlank =
-      builder.create<arith::CmpIOp>(loc, arith::CmpIPredicate::eq, blank, c);
+  auto isBlank = builder.create<mlir::arith::CmpIOp>(
+      loc, mlir::arith::CmpIPredicate::eq, blank, c);
   llvm::SmallVector<mlir::Value> results = {isBlank, index};
   builder.create<fir::ResultOp>(loc, results);
   builder.restoreInsertionPoint(insPt);
   // Compute length after iteration (zero if all blanks)
   mlir::Value newLen =
-      builder.create<arith::AddIOp>(loc, iterWhile.getResult(1), one);
+      builder.create<mlir::arith::AddIOp>(loc, iterWhile.getResult(1), one);
   auto result = builder.create<mlir::arith::SelectOp>(
       loc, iterWhile.getResult(0), zero, newLen);
   return builder.createConvert(loc, builder.getCharacterLengthType(), result);
 }
 
 fir::CharBoxValue
 fir::factory::CharacterExprHelper::createCharacterTemp(mlir::Type type,
                                                        int len) {

 
 bool fir::factory::CharacterExprHelper::isCharacterLiteral(mlir::Type type) {
   if (auto seqType = type.dyn_cast<fir::SequenceType>())
     return (seqType.getShape().size() == 1) &&
            fir::isa_char(seqType.getEleTy());
   return false;
 }
 
-bool fir::factory::CharacterExprHelper::isCharacterScalar(mlir::Type type) {
-  if (type.isa<fir::BoxCharType>())
-    return true;
-  type = fir::unwrapRefType(type);
-  if (auto boxTy = type.dyn_cast<fir::BoxType>())
-    type = boxTy.getEleTy();
-  type = fir::unwrapRefType(type);
-  return !type.isa<fir::SequenceType>() && fir::isa_char(type);
-}
-
 fir::KindTy
 fir::factory::CharacterExprHelper::getCharacterKind(mlir::Type type) {
   assert(isCharacterScalar(type) && "expected scalar character");
   return recoverCharacterType(type).getFKind();
 }
 
 fir::KindTy
 fir::factory::CharacterExprHelper::getCharacterOrSequenceKind(mlir::Type type) {
   return recoverCharacterType(type).getFKind();
 }
 
-bool fir::factory::CharacterExprHelper::isArray(mlir::Type type) {
-  return !isCharacterScalar(type);
-}
-
 bool fir::factory::CharacterExprHelper::hasConstantLengthInType(
     const fir::ExtendedValue &exv) {
   auto charTy = recoverCharacterType(fir::getBase(exv).getType());
   return charTy.hasConstantLen();
 }
 
 mlir::Value
 fir::factory::CharacterExprHelper::createSingletonFromCode(mlir::Value code,

 fir::factory::CharacterExprHelper::readLengthFromBox(mlir::Value box) {
   auto lenTy = builder.getCharacterLengthType();
   auto size = builder.create<fir::BoxEleSizeOp>(loc, lenTy, box);
   auto charTy = recoverCharacterType(box.getType());
   auto bits = builder.getKindMap().getCharacterBitsize(charTy.getFKind());
   auto width = bits / 8;
   if (width > 1) {
     auto widthVal = builder.createIntegerConstant(loc, lenTy, width);
-    return builder.create<arith::DivSIOp>(loc, size, widthVal);
+    return builder.create<mlir::arith::DivSIOp>(loc, size, widthVal);
   }
   return size;
 }
 
 mlir::Value fir::factory::CharacterExprHelper::getLength(mlir::Value memref) {
   auto memrefType = memref.getType();
   auto charType = recoverCharacterType(memrefType);
   assert(charType && "must be a character type");

 fir::factory::extractCharacterProcedureTuple(fir::FirOpBuilder &builder,
                                              mlir::Location loc,
                                              mlir::Value tuple) {
   mlir::TupleType tupleType = tuple.getType().cast<mlir::TupleType>();
   mlir::Value addr = builder.create<fir::ExtractValueOp>(
       loc, tupleType.getType(0), tuple,
       builder.getArrayAttr(
           {builder.getIntegerAttr(builder.getIndexType(), 0)}));
+  mlir::Value proc = [&]() -> mlir::Value {
+    if (auto addrTy = addr.getType().dyn_cast<fir::BoxProcType>())
+      return builder.create<fir::BoxAddrOp>(loc, addrTy.getEleTy(), addr);
+    return addr;
+  }();
   mlir::Value len = builder.create<fir::ExtractValueOp>(
       loc, tupleType.getType(1), tuple,
       builder.getArrayAttr(
           {builder.getIntegerAttr(builder.getIndexType(), 1)}));
-  return {addr, len};
+  return {proc, len};
 }
 
 mlir::Value fir::factory::createCharacterProcedureTuple(
     fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type argTy,
     mlir::Value addr, mlir::Value len) {
   mlir::TupleType tupleType = argTy.cast<mlir::TupleType>();
   addr = builder.createConvert(loc, tupleType.getType(0), addr);
   len = builder.createConvert(loc, tupleType.getType(1), len);
   mlir::Value tuple = builder.create<fir::UndefOp>(loc, tupleType);
   tuple = builder.create<fir::InsertValueOp>(
       loc, tupleType, tuple, addr,
       builder.getArrayAttr(
           {builder.getIntegerAttr(builder.getIndexType(), 0)}));
   tuple = builder.create<fir::InsertValueOp>(
       loc, tupleType, tuple, len,
       builder.getArrayAttr(
           {builder.getIntegerAttr(builder.getIndexType(), 1)}));
   return tuple;
 }
 
-bool fir::factory::isCharacterProcedureTuple(mlir::Type ty) {
-  mlir::TupleType tuple = ty.dyn_cast<mlir::TupleType>();
-  return tuple && tuple.size() == 2 &&
-         tuple.getType(0).isa<mlir::FunctionType>() &&
-         fir::isa_integer(tuple.getType(1));
-}
-
 mlir::Type
 fir::factory::getCharacterProcedureTupleType(mlir::Type funcPointerType) {
   mlir::MLIRContext *context = funcPointerType.getContext();
   mlir::Type lenType = mlir::IntegerType::get(context, 64);
   return mlir::TupleType::get(context, {funcPointerType, lenType});
 }

flang/lib/Optimizer/Builder/FIRBuilder.cpp

 #include "flang/Optimizer/Support/InternalNames.h"
 #include "mlir/Dialect/OpenMP/OpenMPDialect.h"
 #include "llvm/ADT/ArrayRef.h"
 #include "llvm/ADT/StringExtras.h"
 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/ErrorHandling.h"
 #include "llvm/Support/MD5.h"
 
-static constexpr std::size_t nameLengthHashSize = 32;
+static llvm::cl::opt<std::size_t>
+    nameLengthHashSize("length-to-hash-string-literal",
+                       llvm::cl::desc("string literals that exceed this length"
+                                      " will use a hash value as their symbol "
+                                      "name"),
+                       llvm::cl::init(32));
 
 mlir::FuncOp fir::FirOpBuilder::createFunction(mlir::Location loc,
                                                mlir::ModuleOp module,
                                                llvm::StringRef name,
                                                mlir::FunctionType ty) {
   return fir::createFuncOp(loc, module, name, ty);
 }
 
return exv.match(
         llvm::SmallVector<mlir::Value> lenParams{box.getLen()};
         return create<fir::EmboxOp>(loc, boxTy, itemAddr, emptyShape,
                                     emptySlice, lenParams);
       },
       [&](const fir::MutableBoxValue &x) -> mlir::Value {
         return create<fir::LoadOp>(
             loc, fir::factory::getMutableIRBox(*this, loc, x));
       },
-      // UnboxedValue, ProcBoxValue or BoxValue.
       [&](const auto &) -> mlir::Value {
         return create<fir::EmboxOp>(loc, boxTy, itemAddr);
       });
 }
 
+void fir::FirOpBuilder::dumpFunc() { getFunction().dump(); }
+
 static mlir::Value
 genNullPointerComparison(fir::FirOpBuilder &builder, mlir::Location loc,
                          mlir::Value addr,
                          mlir::arith::CmpIPredicate condition) {
   auto intPtrTy = builder.getIntPtrType();
   auto ptrToInt = builder.createConvert(loc, intPtrTy, addr);
   auto c0 = builder.createIntegerConstant(loc, intPtrTy, 0);
   return builder.create<mlir::arith::CmpIOp>(loc, condition, ptrToInt, c0);
return box.match(
         auto idxTy = builder.getIndexType();
         auto dimVal = builder.createIntegerConstant(loc, idxTy, dim);
         return builder
             .create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy, x.getAddr(),
                                     dimVal)
             .getResult(1);
       },
       [&](const fir::MutableBoxValue &x) -> mlir::Value {
-        // MutableBoxValue must be read into another category to work with them
-        // outside of allocation/assignment contexts.
-        fir::emitFatalError(loc, "readExtents on MutableBoxValue");
+        return readExtent(builder, loc,
+                          fir::factory::genMutableBoxRead(builder, loc, x),
+                          dim);
       },
       [&](const auto &) -> mlir::Value {
         fir::emitFatalError(loc, "extent inquiry on scalar");
       });
 }
 
 mlir::Value fir::factory::readLowerBound(fir::FirOpBuilder &builder,
                                          mlir::Location loc,
fir::ExtendedValue fir::factory::arraySectionElementToExtendedValue(
   if (sliceOp.getFields().empty())
     return arrayElementToExtendedValue(builder, loc, array, element);
   // For F95, using componentToExtendedValue will work, but when PDTs are
   // lowered. It will be required to go down the slice to propagate the length
   // parameters.
   return fir::factory::componentToExtendedValue(builder, loc, element);
 }
 
-mlir::TupleType
-fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) {
-  mlir::IntegerType i64Ty = builder.getIntegerType(64);
-  auto arrTy = fir::SequenceType::get(builder.getIntegerType(8), 1);
-  auto buffTy = fir::HeapType::get(arrTy);
-  auto extTy = fir::SequenceType::get(i64Ty, 1);
-  auto shTy = fir::HeapType::get(extTy);
-  return mlir::TupleType::get(builder.getContext(), {i64Ty, buffTy, shTy});
-}
-
-mlir::Value fir::factory::createZeroValue(fir::FirOpBuilder &builder,
-                                          mlir::Location loc, mlir::Type type) {
-  mlir::Type i1 = builder.getIntegerType(1);
-  if (type.isa<fir::LogicalType>() || type == i1)
-    return builder.createConvert(loc, type, builder.createBool(loc, false));
-  if (fir::isa_integer(type))
-    return builder.createIntegerConstant(loc, type, 0);
-  if (fir::isa_real(type))
-    return builder.createRealZeroConstant(loc, type);
-  if (fir::isa_complex(type)) {
-    fir::factory::Complex complexHelper(builder, loc);
-    mlir::Type partType = complexHelper.getComplexPartType(type);
-    mlir::Value zeroPart = builder.createRealZeroConstant(loc, partType);
-    return complexHelper.createComplex(type, zeroPart, zeroPart);
-  }
-  fir::emitFatalError(loc, "internal: trying to generate zero value of non "
-                           "numeric or logical type");
-}
-
 void fir::factory::genScalarAssignment(fir::FirOpBuilder &builder,
                                        mlir::Location loc,
                                        const fir::ExtendedValue &lhs,
                                        const fir::ExtendedValue &rhs) {
   assert(lhs.rank() == 0 && rhs.rank() == 0 && "must be scalars");
   auto type = fir::unwrapSequenceType(
       fir::unwrapPassByRefType(fir::getBase(lhs).getType()));
   if (type.isa<fir::CharacterType>()) {
void fir::factory::genRecordAssignment(fir::FirOpBuilder &builder,
   // component by component assignment. Note that a single fir.load/fir.store
   // could be used on "small" record types, but as the type size grows, this
   // leads to issues in LLVM (long compile times, long IR files, and even
   // asserts at some point). Since there is no good size boundary, just always
   // use component by component assignment here.
   genComponentByComponentAssignment(builder, loc, lhs, rhs);
 }
 
+mlir::TupleType
+fir::factory::getRaggedArrayHeaderType(fir::FirOpBuilder &builder) {
+  mlir::IntegerType i64Ty = builder.getIntegerType(64);
+  auto arrTy = fir::SequenceType::get(builder.getIntegerType(8), 1);
+  auto buffTy = fir::HeapType::get(arrTy);
+  auto extTy = fir::SequenceType::get(i64Ty, 1);
+  auto shTy = fir::HeapType::get(extTy);
+  return mlir::TupleType::get(builder.getContext(), {i64Ty, buffTy, shTy});
+}
+
 mlir::Value fir::factory::genLenOfCharacter(
     fir::FirOpBuilder &builder, mlir::Location loc, fir::ArrayLoadOp arrLoad,
     llvm::ArrayRef<mlir::Value> path, llvm::ArrayRef<mlir::Value> substring) {
   llvm::SmallVector<mlir::Value> typeParams(arrLoad.getTypeparams());
   return genLenOfCharacter(builder, loc,
                            arrLoad.getType().cast<fir::SequenceType>(),
                            arrLoad.getMemref(), typeParams, path, substring);
 }
if (typeParams.empty()) {
     fir::emitFatalError(loc, "array_load must have typeparams");
   }
   if (fir::isa_char(seqTy.getEleTy())) {
     assert(typeParams.size() == 1 && "too many typeparams");
     return typeParams.front();
   }
   TODO(loc, "LEN of character must be computed at runtime");
 }
+
+mlir::Value fir::factory::createZeroValue(fir::FirOpBuilder &builder,
+                                          mlir::Location loc, mlir::Type type) {
+  mlir::Type i1 = builder.getIntegerType(1);
+  if (type.isa<fir::LogicalType>() || type == i1)
+    return builder.createConvert(loc, type, builder.createBool(loc, false));
+  if (fir::isa_integer(type))
+    return builder.createIntegerConstant(loc, type, 0);
+  if (fir::isa_real(type))
+    return builder.createRealZeroConstant(loc, type);
+  if (fir::isa_complex(type)) {
+    fir::factory::Complex complexHelper(builder, loc);
+    mlir::Type partType = complexHelper.getComplexPartType(type);
+    mlir::Value zeroPart = builder.createRealZeroConstant(loc, partType);
+    return complexHelper.createComplex(type, zeroPart, zeroPart);
+  }
+  fir::emitFatalError(loc, "internal: trying to generate zero value of non "
+                           "numeric or logical type");
+}

flang/lib/Optimizer/Builder/LowLevelIntrinsics.cpp

 // Target-specific calls, such as OS functions, should be factored in other
 // file(s).
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 
+mlir::FuncOp fir::factory::getLlvmMemcpy(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
+                                        builder.getI1Type()};
+  auto memcpyTy =
+      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
+  return builder.addNamedFunction(builder.getUnknownLoc(),
+                                  "llvm.memcpy.p0i8.p0i8.i64", memcpyTy);
+}
+
+mlir::FuncOp fir::factory::getLlvmMemmove(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
+                                        builder.getI1Type()};
+  auto memmoveTy =
+      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
+  return builder.addNamedFunction(builder.getUnknownLoc(),
+                                  "llvm.memmove.p0i8.p0i8.i64", memmoveTy);
+}
+
+mlir::FuncOp fir::factory::getLlvmMemset(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  llvm::SmallVector<mlir::Type> args = {ptrTy, ptrTy, builder.getI64Type(),
+                                        builder.getI1Type()};
+  auto memsetTy =
+      mlir::FunctionType::get(builder.getContext(), args, llvm::None);
+  return builder.addNamedFunction(builder.getUnknownLoc(),
+                                  "llvm.memset.p0i8.p0i8.i64", memsetTy);
+}
+
+mlir::FuncOp fir::factory::getRealloc(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  llvm::SmallVector<mlir::Type> args = {ptrTy, builder.getI64Type()};
+  auto reallocTy = mlir::FunctionType::get(builder.getContext(), args, {ptrTy});
+  return builder.addNamedFunction(builder.getUnknownLoc(), "realloc",
+                                  reallocTy);
+}
+
 mlir::FuncOp fir::factory::getLlvmStackSave(fir::FirOpBuilder &builder) {
   auto ptrTy = builder.getRefType(builder.getIntegerType(8));
   auto funcTy =
       mlir::FunctionType::get(builder.getContext(), llvm::None, {ptrTy});
   return builder.addNamedFunction(builder.getUnknownLoc(), "llvm.stacksave",
                                   funcTy);
 }
 
 mlir::FuncOp fir::factory::getLlvmStackRestore(fir::FirOpBuilder &builder) {
   auto ptrTy = builder.getRefType(builder.getIntegerType(8));
   auto funcTy =
       mlir::FunctionType::get(builder.getContext(), {ptrTy}, llvm::None);
   return builder.addNamedFunction(builder.getUnknownLoc(), "llvm.stackrestore",
                                   funcTy);
 }
+
+mlir::FuncOp fir::factory::getLlvmInitTrampoline(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  auto funcTy = mlir::FunctionType::get(builder.getContext(),
+                                        {ptrTy, ptrTy, ptrTy}, llvm::None);
+  return builder.addNamedFunction(builder.getUnknownLoc(),
+                                  "llvm.init.trampoline", funcTy);
+}
+
+mlir::FuncOp fir::factory::getLlvmAdjustTrampoline(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  auto funcTy = mlir::FunctionType::get(builder.getContext(), {ptrTy}, {ptrTy});
+  return builder.addNamedFunction(builder.getUnknownLoc(),
+                                  "llvm.adjust.trampoline", funcTy);
+}

flang/lib/Optimizer/Builder/MutableBox.cpp

auto addr = MutablePropertyReader{builder, loc, box}.read(lbounds, extents,
                                                               lengths);
     updateIRBox(addr, lbounds, extents, lengths);
   }
 
 private:
   /// Update the IR box (fir.ref<fir.box<T>>) of the MutableBoxValue.
   void updateIRBox(mlir::Value addr, mlir::ValueRange lbounds,
                    mlir::ValueRange extents, mlir::ValueRange lengths) {
-    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);
-      }
-    }
-    mlir::Value emptySlice;
-    // Ignore lengths if already constant in the box type (this would trigger an
-    // error in the embox).
-    llvm::SmallVector<mlir::Value> cleanedLengths;
-    mlir::Value irBox;
-    if (addr.getType().isa<fir::BoxType>()) {
-      // The entity is already boxed.
-      irBox = builder.createConvert(loc, box.getBoxTy(), addr);
-    } else {
-      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;
-      }
-      irBox = builder.create<fir::EmboxOp>(loc, box.getBoxTy(), cleanedAddr,
-                                           shape, emptySlice, cleanedLengths);
-    }
+    mlir::Value irBox =
+        createNewFirBox(builder, loc, box, addr, lbounds, extents, lengths);
     builder.create<fir::StoreOp>(loc, irBox, box.getAddr());
   }
 
   /// Update the set of property variables of the MutableBoxValue.
   void updateMutableProperties(mlir::Value addr, mlir::ValueRange lbounds,
                                mlir::ValueRange extents,
                                mlir::ValueRange lengths) {
     auto castAndStore = [&](mlir::Value val, mlir::Value addr) {

 
 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();
-  llvm::SmallVector<mlir::Value> lengths;
-  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");
-    }
-  }
-  mlir::Value heap = builder.create<fir::AllocMemOp>(
-      loc, box.getBaseTy(), allocName, lengths, extents);
-  // TODO: run initializer if any. Currently, there is no way to know this is
-  // required here.
+  auto lengths = getNewLengths(builder, loc, box, lenParams);
+  auto heap = builder.create<fir::AllocMemOp>(loc, box.getBaseTy(), allocName,
+                                              lengths, extents);
   MutablePropertyWriter{builder, loc, box}.updateMutableBox(heap, lbounds,
                                                             extents, lengths);
+  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 = fir::factory::getMutableIRBox(builder, loc, box);
+    fir::runtime::genDerivedTypeInitialize(builder, loc, irBox);
+  }
 }
 
 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();

flang/lib/Optimizer/CodeGen/BoxedProcedure.cpp

+//===-- BoxedProcedure.cpp ------------------------------------------------===//
+//
+// 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 "PassDetail.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
+#include "flang/Optimizer/CodeGen/CodeGen.h"
+#include "flang/Optimizer/Dialect/FIRDialect.h"
+#include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/Dialect/FIRType.h"
+#include "flang/Optimizer/Support/FIRContext.h"
+#include "flang/Optimizer/Support/FatalError.h"
+#include "mlir/IR/PatternMatch.h"
+#include "mlir/Pass/Pass.h"
+#include "mlir/Transforms/DialectConversion.h"
+
+#define DEBUG_TYPE "flang-procedure-pointer"
+
+using namespace fir;
+
+namespace {
+/// Options to the procedure pointer pass.
+struct BoxedProcedureOptions {
+  // Lower the boxproc abstraction to function pointers and thunks where
+  // required.
+  bool useThunks = true;
+};
+
+/// This type converter rewrites all `!fir.boxproc<Func>` types to `Func` types.
+class BoxprocTypeRewriter : public mlir::TypeConverter {
+public:
+  using mlir::TypeConverter::convertType;
+
+  /// Does the type \p ty need to be converted?
+  /// Any type that is a `!fir.boxproc` in whole or in part will need to be
+  /// converted to a function type to lower the IR to function pointer form in
+  /// the default implementation performed in this pass. Other implementations
+  /// are possible, so those may convert `!fir.boxproc` to some other type or
+  /// not at all depending on the implementation target's characteristics and
+  /// preference.
+  bool needsConversion(mlir::Type ty) {
+    if (ty.isa<BoxProcType>())
+      return true;
+    if (auto funcTy = ty.dyn_cast<mlir::FunctionType>()) {
+      for (auto t : funcTy.getInputs())
+        if (needsConversion(t))
+          return true;
+      for (auto t : funcTy.getResults())
+        if (needsConversion(t))
+          return true;
+      return false;
+    }
+    if (auto tupleTy = ty.dyn_cast<mlir::TupleType>()) {
+      for (auto t : tupleTy.getTypes())
+        if (needsConversion(t))
+          return true;
+      return false;
+    }
+    if (auto recTy = ty.dyn_cast<RecordType>()) {
+      bool result = false;
+      visitedTypes.push_back(recTy);
+      for (auto t : recTy.getTypeList()) {
+        if (llvm::any_of(visitedTypes,
+                         [&](mlir::Type rt) { return rt == recTy; }))
+          continue;
+        if (needsConversion(t.second)) {
+          result = true;
+          break;
+        }
+      }
+      visitedTypes.pop_back();
+      return result;
+    }
+    if (auto boxTy = ty.dyn_cast<BoxType>())
+      return needsConversion(boxTy.getEleTy());
+    if (isa_ref_type(ty))
+      return needsConversion(unwrapRefType(ty));
+    if (auto t = ty.dyn_cast<SequenceType>())
+      return needsConversion(unwrapSequenceType(ty));
+    return false;
+  }
+
+  BoxprocTypeRewriter() {
+    addConversion([](mlir::Type ty) { return ty; });
+    addConversion([](BoxProcType boxproc) { return boxproc.getEleTy(); });
+    addConversion([&](mlir::TupleType tupTy) {
+      llvm::SmallVector<mlir::Type> memTys;
+      for (auto ty : tupTy.getTypes())
+        memTys.push_back(convertType(ty));
+      return mlir::TupleType::get(tupTy.getContext(), memTys);
+    });
+    addConversion([&](mlir::FunctionType funcTy) {
+      llvm::SmallVector<mlir::Type> inTys;
+      llvm::SmallVector<mlir::Type> resTys;
+      for (auto ty : funcTy.getInputs())
+        inTys.push_back(convertType(ty));
+      for (auto ty : funcTy.getResults())
+        resTys.push_back(convertType(ty));
+      return mlir::FunctionType::get(funcTy.getContext(), inTys, resTys);
+    });
+    addConversion([&](ReferenceType ty) {
+      return ReferenceType::get(convertType(ty.getEleTy()));
+    });
+    addConversion([&](PointerType ty) {
+      return PointerType::get(convertType(ty.getEleTy()));
+    });
+    addConversion(
+        [&](HeapType ty) { return HeapType::get(convertType(ty.getEleTy())); });
+    addConversion(
+        [&](BoxType ty) { return BoxType::get(convertType(ty.getEleTy())); });
+    addConversion([&](SequenceType ty) {
+      // TODO: add ty.getLayoutMap() as needed.
+      return SequenceType::get(ty.getShape(), convertType(ty.getEleTy()));
+    });
+    addConversion([&](RecordType ty) {
+      // FIR record types can have recursive references, so conversion is a bit
+      // more complex than the other types. This conversion is not needed
+      // presently, so just emit a TODO message. Need to consider the uniqued
+      // name of the record, etc.
+      fir::emitFatalError(
+          mlir::UnknownLoc::get(ty.getContext()),
+          "not yet implemented: record type with a boxproc type");
+      return RecordType::get(ty.getContext(), "*fixme*");
+    });
+    addArgumentMaterialization(materializeProcedure);
+    addSourceMaterialization(materializeProcedure);
+    addTargetMaterialization(materializeProcedure);
+  }
+
+  static mlir::Value materializeProcedure(mlir::OpBuilder &builder,
+                                          BoxProcType type,
+                                          mlir::ValueRange inputs,
+                                          mlir::Location loc) {
+    assert(inputs.size() == 1);
+    return builder.create<ConvertOp>(loc, unwrapRefType(type.getEleTy()),
+                                     inputs[0]);
+  }
+
+private:
+  llvm::SmallVector<mlir::Type> visitedTypes;
+};
+
+/// A `boxproc` is an abstraction for a Fortran procedure reference. Typically,
+/// Fortran procedures can be referenced directly through a function pointer.
+/// However, Fortran has one-level dynamic scoping between a host procedure and
+/// its internal procedures. This allows internal procedures to directly access
+/// and modify the state of the host procedure's variables.
+///
+/// There are any number of possible implementations possible.
+///
+/// The implementation used here is to convert `boxproc` values to function
+/// pointers everywhere. If a `boxproc` value includes a frame pointer to the
+/// host procedure's data, then a thunk will be created at runtime to capture
+/// the frame pointer during execution. In LLVM IR, the frame pointer is
+/// designated with the `nest` attribute. The thunk's address will then be used
+/// as the call target instead of the original function's address directly.
+class BoxedProcedurePass : public BoxedProcedurePassBase<BoxedProcedurePass> {
+public:
+  BoxedProcedurePass() { options = {true}; }
+  BoxedProcedurePass(bool useThunks) { options = {useThunks}; }
+
+  inline mlir::ModuleOp getModule() { return getOperation(); }
+
+  void runOnOperation() override final {
+    if (options.useThunks) {
+      auto *context = &getContext();
+      mlir::IRRewriter rewriter(context);
+      BoxprocTypeRewriter typeConverter;
+      mlir::Dialect *firDialect = context->getLoadedDialect("fir");
+      getModule().walk([&](mlir::Operation *op) {
+        if (auto addr = mlir::dyn_cast<BoxAddrOp>(op)) {
+          auto ty = addr.getVal().getType();
+          if (typeConverter.needsConversion(ty) ||
+              ty.isa<mlir::FunctionType>()) {
+            // Rewrite all `fir.box_addr` ops on values of type `!fir.boxproc`
+            // or function type to be `fir.convert` ops.
+            rewriter.setInsertionPoint(addr);
+            rewriter.replaceOpWithNewOp<ConvertOp>(
+                addr, typeConverter.convertType(addr.getType()), addr.getVal());
+          }
+        } else if (auto func = mlir::dyn_cast<mlir::FuncOp>(op)) {
+          mlir::FunctionType ty = func.getFunctionType();
+          if (typeConverter.needsConversion(ty)) {
+            rewriter.startRootUpdate(func);
+            auto toTy =
+                typeConverter.convertType(ty).cast<mlir::FunctionType>();
+            if (!func.empty())
+              for (auto e : llvm::enumerate(toTy.getInputs())) {
+                unsigned i = e.index();
+                auto &block = func.front();
+                block.insertArgument(i, e.value(), func.getLoc());
+                block.getArgument(i + 1).replaceAllUsesWith(
+                    block.getArgument(i));
+                block.eraseArgument(i + 1);
+              }
+            func.setType(toTy);
+            rewriter.finalizeRootUpdate(func);
+          }
+        } else if (auto embox = mlir::dyn_cast<EmboxProcOp>(op)) {
+          // Rewrite all `fir.emboxproc` ops to either `fir.convert` or a thunk
+          // as required.
+          mlir::Type toTy = embox.getType().cast<BoxProcType>().getEleTy();
+          rewriter.setInsertionPoint(embox);
+          if (embox.getHost()) {
+            // Create the thunk.
+            auto module = embox->getParentOfType<mlir::ModuleOp>();
+            FirOpBuilder builder(rewriter, getKindMapping(module));
+            auto loc = embox.getLoc();
+            mlir::Type i8Ty = builder.getI8Type();
+            mlir::Type i8Ptr = builder.getRefType(i8Ty);
+            mlir::Type buffTy = SequenceType::get({32}, i8Ty);
+            auto buffer = builder.create<AllocaOp>(loc, buffTy);
+            mlir::Value closure =
+                builder.createConvert(loc, i8Ptr, embox.getHost());
+            mlir::Value tramp = builder.createConvert(loc, i8Ptr, buffer);
+            mlir::Value func =
+                builder.createConvert(loc, i8Ptr, embox.getFunc());
+            builder.create<fir::CallOp>(
+                loc, factory::getLlvmInitTrampoline(builder),
+                llvm::ArrayRef<mlir::Value>{tramp, func, closure});
+            auto adjustCall = builder.create<fir::CallOp>(
+                loc, factory::getLlvmAdjustTrampoline(builder),
+                llvm::ArrayRef<mlir::Value>{tramp});
+            rewriter.replaceOpWithNewOp<ConvertOp>(embox, toTy,
+                                                   adjustCall.getResult(0));
+          } else {
+            // Just forward the function as a pointer.
+            rewriter.replaceOpWithNewOp<ConvertOp>(embox, toTy,
+                                                   embox.getFunc());
+          }
+        } else if (auto mem = mlir::dyn_cast<AllocaOp>(op)) {
+          auto ty = mem.getType();
+          if (typeConverter.needsConversion(ty)) {
+            rewriter.setInsertionPoint(mem);
+            auto toTy = typeConverter.convertType(unwrapRefType(ty));
+            bool isPinned = mem.getPinned();
+            llvm::StringRef uniqName;
+            if (mem.getUniqName().hasValue())
+              uniqName = mem.getUniqName().getValue();
+            llvm::StringRef bindcName;
+            if (mem.getBindcName().hasValue())
+              bindcName = mem.getBindcName().getValue();
+            rewriter.replaceOpWithNewOp<AllocaOp>(
+                mem, toTy, uniqName, bindcName, isPinned, mem.getTypeparams(),
+                mem.getShape());
+          }
+        } else if (auto mem = mlir::dyn_cast<AllocMemOp>(op)) {
+          auto ty = mem.getType();
+          if (typeConverter.needsConversion(ty)) {
+            rewriter.setInsertionPoint(mem);
+            auto toTy = typeConverter.convertType(unwrapRefType(ty));
+            llvm::StringRef uniqName;
+            if (mem.getUniqName().hasValue())
+              uniqName = mem.getUniqName().getValue();
+            llvm::StringRef bindcName;
+            if (mem.getBindcName().hasValue())
+              bindcName = mem.getBindcName().getValue();
+            rewriter.replaceOpWithNewOp<AllocMemOp>(
+                mem, toTy, uniqName, bindcName, mem.getTypeparams(),
+                mem.getShape());
+          }
+        } else if (auto coor = mlir::dyn_cast<CoordinateOp>(op)) {
+          auto ty = coor.getType();
+          mlir::Type baseTy = coor.getBaseType();
+          if (typeConverter.needsConversion(ty) ||
+              typeConverter.needsConversion(baseTy)) {
+            rewriter.setInsertionPoint(coor);
+            auto toTy = typeConverter.convertType(ty);
+            auto toBaseTy = typeConverter.convertType(baseTy);
+            rewriter.replaceOpWithNewOp<CoordinateOp>(coor, toTy, coor.getRef(),
+                                                      coor.getCoor(), toBaseTy);
+          }
+        } else if (auto index = mlir::dyn_cast<FieldIndexOp>(op)) {
+          auto ty = index.getType();
+          mlir::Type onTy = index.getOnType();
+          if (typeConverter.needsConversion(ty) ||
+              typeConverter.needsConversion(onTy)) {
+            rewriter.setInsertionPoint(index);
+            auto toTy = typeConverter.convertType(ty);
+            auto toOnTy = typeConverter.convertType(onTy);
+            rewriter.replaceOpWithNewOp<FieldIndexOp>(
+                index, toTy, index.getFieldId(), toOnTy, index.getTypeparams());
+          }
+        } else if (auto index = mlir::dyn_cast<LenParamIndexOp>(op)) {
+          auto ty = index.getType();
+          mlir::Type onTy = index.getOnType();
+          if (typeConverter.needsConversion(ty) ||
+              typeConverter.needsConversion(onTy)) {
+            rewriter.setInsertionPoint(index);
+            auto toTy = typeConverter.convertType(ty);
+            auto toOnTy = typeConverter.convertType(onTy);
+            rewriter.replaceOpWithNewOp<LenParamIndexOp>(
+                mem, toTy, index.getFieldId(), toOnTy);
+          }
+        } else if (op->getDialect() == firDialect) {
+          rewriter.startRootUpdate(op);
+          for (auto i : llvm::enumerate(op->getResultTypes()))
+            if (typeConverter.needsConversion(i.value())) {
+              auto toTy = typeConverter.convertType(i.value());
+              op->getResult(i.index()).setType(toTy);
+            }
+          rewriter.finalizeRootUpdate(op);
+        }
+      });
+    }
+    // TODO: any alternative implementation. Note: currently, the default code
+    // gen will not be able to handle boxproc and will give an error.
+  }
+
+private:
+  BoxedProcedureOptions options;
+};
+} // namespace
+
+std::unique_ptr<mlir::Pass> fir::createBoxedProcedurePass() {
+  return std::make_unique<BoxedProcedurePass>();
+}
+
+std::unique_ptr<mlir::Pass> fir::createBoxedProcedurePass(bool useThunks) {
+  return std::make_unique<BoxedProcedurePass>(useThunks);
+}

flang/lib/Optimizer/CodeGen/CMakeLists.txt

 add_flang_library(FIRCodeGen
+  BoxedProcedure.cpp
   CGOps.cpp
   CodeGen.cpp
   PreCGRewrite.cpp
   Target.cpp
   TargetRewrite.cpp
 
   DEPENDS
   FIRBuilder

flang/lib/Optimizer/CodeGen/TargetRewrite.cpp

 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #include "PassDetail.h"
 #include "Target.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/Character.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/CodeGen/CodeGen.h"
 #include "flang/Optimizer/Dialect/FIRDialect.h"
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Optimizer/Dialect/FIRType.h"
 #include "flang/Optimizer/Support/FIRContext.h"
 #include "mlir/Transforms/DialectConversion.h"
 #include "llvm/ADT/STLExtras.h"
public:
   void runOnOperation() override final {
     auto &context = getContext();
     mlir::OpBuilder rewriter(&context);
 
     auto mod = getModule();
     if (!forcedTargetTriple.empty())
       setTargetTriple(mod, forcedTargetTriple);
 
-    auto specifics = CodeGenSpecifics::get(getOperation().getContext(),
-                                           getTargetTriple(getOperation()),
-                                           getKindMapping(getOperation()));
+    auto specifics = CodeGenSpecifics::get(
+        mod.getContext(), getTargetTriple(mod), getKindMapping(mod));
     setMembers(specifics.get(), &rewriter);
 
     // Perform type conversion on signatures and call sites.
     if (mlir::failed(convertTypes(mod))) {
       mlir::emitError(mlir::UnknownLoc::get(&context),
                       "error in converting types to target abi");
       signalPassFailure();
     }
for (auto e : llvm::enumerate(
           })
           .template Case<fir::ComplexType>([&](fir::ComplexType cmplx) {
             rewriteCallComplexInputType(cmplx, oper, newInTys, newOpers);
           })
           .template Case<mlir::ComplexType>([&](mlir::ComplexType cmplx) {
             rewriteCallComplexInputType(cmplx, oper, newInTys, newOpers);
           })
           .template Case<mlir::TupleType>([&](mlir::TupleType tuple) {
-            if (factory::isCharacterProcedureTuple(tuple)) {
+            if (isCharacterProcedureTuple(tuple)) {
               mlir::ModuleOp module = getModule();
               if constexpr (std::is_same_v<std::decay_t<A>, fir::CallOp>) {
                 if (callOp.getCallee()) {
                   llvm::StringRef charProcAttr =
-                      fir::getCharacterProcedureDummyAttrName();
+                      getCharacterProcedureDummyAttrName();
                   // The charProcAttr attribute is only used as a safety to
                   // confirm that this is a dummy procedure and should be split.
                   // It cannot be used to match because attributes are not
                   // available in case of indirect calls.
                   auto funcOp =
                       module.lookupSymbol<mlir::FuncOp>(*callOp.getCallee());
                   if (funcOp &&
                       !funcOp.template getArgAttrOfType<mlir::UnitAttr>(
for (mlir::Type ty : addrTy.getInputs()) {
           })
           .Case<fir::ComplexType>([&](fir::ComplexType ty) {
             lowerComplexSignatureArg(ty, newInTys);
           })
           .Case<mlir::ComplexType>([&](mlir::ComplexType ty) {
             lowerComplexSignatureArg(ty, newInTys);
           })
           .Case<mlir::TupleType>([&](mlir::TupleType tuple) {
-            if (factory::isCharacterProcedureTuple(tuple)) {
+            if (isCharacterProcedureTuple(tuple)) {
               newInTys.push_back(tuple.getType(0));
               trailingInTys.push_back(tuple.getType(1));
             } else {
               newInTys.push_back(ty);
             }
           })
           .Default([&](mlir::Type ty) { newInTys.push_back(ty); });
     }
bool hasPortableSignature(mlir::Type signature) {
     auto func = signature.dyn_cast<mlir::FunctionType>();
     for (auto ty : func.getResults())
       if ((ty.isa<BoxCharType>() && !noCharacterConversion) ||
           (isa_complex(ty) && !noComplexConversion)) {
         LLVM_DEBUG(llvm::dbgs() << "rewrite " << signature << " for target\n");
         return false;
       }
     for (auto ty : func.getInputs())
-      if (((ty.isa<BoxCharType>() || factory::isCharacterProcedureTuple(ty)) &&
+      if (((ty.isa<BoxCharType>() || isCharacterProcedureTuple(ty)) &&
            !noCharacterConversion) ||
           (isa_complex(ty) && !noComplexConversion)) {
         LLVM_DEBUG(llvm::dbgs() << "rewrite " << signature << " for target\n");
         return false;
       }
     return true;
   }
 
+  /// Determine if the signature has host associations. The host association
+  /// argument may need special target specific rewriting.
+  static bool hasHostAssociations(mlir::FuncOp func) {
+    std::size_t end = func.getFunctionType().getInputs().size();
+    for (std::size_t i = 0; i < end; ++i)
+      if (func.getArgAttrOfType<mlir::UnitAttr>(i, getHostAssocAttrName()))
+        return true;
+    return false;
+  }
+
   /// Rewrite the signatures and body of the `FuncOp`s in the module for
   /// the immediately subsequent target code gen.
   void convertSignature(mlir::FuncOp func) {
     auto funcTy = func.getFunctionType().cast<mlir::FunctionType>();
-    if (hasPortableSignature(funcTy))
+    if (hasPortableSignature(funcTy) && !hasHostAssociations(func))
       return;
     llvm::SmallVector<mlir::Type> newResTys;
     llvm::SmallVector<mlir::Type> newInTys;
     llvm::SmallVector<FixupTy> fixups;
 
     // Convert return value(s)
     for (auto ty : funcTy.getResults())
       llvm::TypeSwitch<mlir::Type>(ty)
for (auto e : llvm::enumerate(funcTy.getInputs())) {
           })
           .Case<mlir::ComplexType>([&](mlir::ComplexType cmplx) {
             if (noComplexConversion)
               newInTys.push_back(cmplx);
             else
               doComplexArg(func, cmplx, newInTys, fixups);
           })
           .Case<mlir::TupleType>([&](mlir::TupleType tuple) {
-            if (factory::isCharacterProcedureTuple(tuple)) {
+            if (isCharacterProcedureTuple(tuple)) {
               fixups.emplace_back(FixupTy::Codes::TrailingCharProc,
                                   newInTys.size(), trailingTys.size());
               newInTys.push_back(tuple.getType(0));
               trailingTys.push_back(tuple.getType(1));
             } else {
               newInTys.push_back(ty);
             }
           })
           .Default([&](mlir::Type ty) { newInTys.push_back(ty); });
+      if (func.getArgAttrOfType<mlir::UnitAttr>(index,
+                                                getHostAssocAttrName())) {
+        func.setArgAttr(index, "llvm.nest", rewriter->getUnitAttr());
+      }
     }
 
     if (!func.empty()) {
       // If the function has a body, then apply the fixups to the arguments and
       // return ops as required. These fixups are done in place.
       auto loc = func.getLoc();
       const auto fixupSize = fixups.size();
       const auto oldArgTys = func.getFunctionType().getInputs();
if (!func.empty()) {
           auto boxTy = oldArgTys[fixup.index - offset];
           rewriter->setInsertionPointToStart(&func.front());
           auto box =
               rewriter->create<EmboxCharOp>(loc, boxTy, newBufArg, newLenArg);
           func.getArgument(fixup.index + 1).replaceAllUsesWith(box);
           func.front().eraseArgument(fixup.index + 1);
         } break;
         case FixupTy::Codes::TrailingCharProc: {
-          // The FIR character procedure argument tuple has been split into a
+          // The FIR character procedure argument tuple must be split into a
           // pair of distinct arguments. The first part of the pair appears in
           // the original argument position. The second part of the pair is
           // appended after all the original arguments.
           auto newProcPointerArg = func.front().insertArgument(
               fixup.index, newInTys[fixup.index], loc);
           auto newLenArg =
               func.front().addArgument(trailingTys[fixup.second], loc);
           auto tupleType = oldArgTys[fixup.index - offset];

flang/lib/Optimizer/CodeGen/TypeConverter.h

public:
   /// Convert fir.box type to the corresponding llvm struct type instead of a
   /// pointer to this struct type.
   mlir::Type convertBoxTypeAsStruct(BoxType box) {
     return convertBoxType(box)
         .cast<mlir::LLVM::LLVMPointerType>()
         .getElementType();
   }
 
+  // fir.boxproc<any>  -->  llvm<"{ any*, i8* }">
+  mlir::Type convertBoxProcType(BoxProcType boxproc) {
+    auto funcTy = convertType(boxproc.getEleTy());
+    auto i8PtrTy = mlir::LLVM::LLVMPointerType::get(
+        mlir::IntegerType::get(&getContext(), 8));
+    llvm::SmallVector<mlir::Type, 2> tuple = {funcTy, i8PtrTy};
+    return mlir::LLVM::LLVMStructType::getLiteral(&getContext(), tuple,
+                                                  /*isPacked=*/false);
+  }
+
   unsigned characterBitsize(fir::CharacterType charTy) {
     return kindMapping.getCharacterBitsize(charTy.getFKind());
   }
 
   // fir.char<k,?>  -->  llvm<"ix">          where ix is scaled by kind mapping
   // fir.char<k,n>  -->  llvm.array<n x "ix">
   mlir::Type convertCharType(fir::CharacterType charTy) {
     auto iTy = mlir::IntegerType::get(&getContext(), characterBitsize(charTy));

flang/lib/Optimizer/Dialect/FIROps.cpp

if (!eleTy.dyn_cast_or_null<CharacterType>())
     return mlir::failure();
   return mlir::success();
 }
 
 //===----------------------------------------------------------------------===//
 // EmboxProcOp
 //===----------------------------------------------------------------------===//
 
-mlir::ParseResult EmboxProcOp::parse(mlir::OpAsmParser &parser,
-                                     mlir::OperationState &result) {
-  mlir::SymbolRefAttr procRef;
-  if (parser.parseAttribute(procRef, "funcname", result.attributes))
-    return mlir::failure();
-  bool hasTuple = false;
-  mlir::OpAsmParser::UnresolvedOperand tupleRef;
-  if (!parser.parseOptionalComma()) {
-    if (parser.parseOperand(tupleRef))
-      return mlir::failure();
-    hasTuple = true;
-  }
-  mlir::FunctionType type;
-  if (parser.parseColon() || parser.parseLParen() || parser.parseType(type))
-    return mlir::failure();
-  result.addAttribute("functype", mlir::TypeAttr::get(type));
-  if (hasTuple) {
-    mlir::Type tupleType;
-    if (parser.parseComma() || parser.parseType(tupleType) ||
-        parser.resolveOperand(tupleRef, tupleType, result.operands))
-      return mlir::failure();
-  }
-  mlir::Type boxType;
-  if (parser.parseRParen() || parser.parseArrow() ||
-      parser.parseType(boxType) || parser.addTypesToList(boxType, result.types))
-    return mlir::failure();
-  return mlir::success();
-}
-
-void EmboxProcOp::print(mlir::OpAsmPrinter &p) {
-  p << ' ' << getOperation()->getAttr("funcname");
-  auto h = getHost();
-  if (h) {
-    p << ", ";
-    p.printOperand(h);
-  }
-  p << " : (" << getOperation()->getAttr("functype");
-  if (h)
-    p << ", " << h.getType();
-  p << ") -> " << getType();
-}
-
 mlir::LogicalResult EmboxProcOp::verify() {
   // host bindings (optional) must be a reference to a tuple
   if (auto h = getHost()) {
-    if (auto r = h.getType().dyn_cast<ReferenceType>()) {
-      if (!r.getEleTy().dyn_cast<mlir::TupleType>())
-        return mlir::failure();
-    } else {
-      return mlir::failure();
-    }
-  }
+    if (auto r = h.getType().dyn_cast<ReferenceType>())
+      if (r.getEleTy().dyn_cast<mlir::TupleType>())
+        return mlir::success();
   return mlir::success();
 }
 
 //===----------------------------------------------------------------------===//
 // GenTypeDescOp
 //===----------------------------------------------------------------------===//
 
 void fir::GenTypeDescOp::build(OpBuilder &, OperationState &result,

flang/lib/Optimizer/Transforms/ExternalNameConversion.cpp

if (fir::NameUniquer::isExternalFacingUniquedName(result)) {
           SymbolRefAttr::get(op.getContext(), mangleExternalName(result));
       rewriter.replaceOpWithNewOp<fir::AddrOfOp>(op, op.getResTy().getType(),
                                                  newName);
     }
     return success();
   }
 };
 
-struct MangleNameOnEmboxProcOp
-    : public mlir::OpRewritePattern<fir::EmboxProcOp> {
-public:
-  using OpRewritePattern::OpRewritePattern;
-
-  mlir::LogicalResult
-  matchAndRewrite(fir::EmboxProcOp op,
-                  mlir::PatternRewriter &rewriter) const override {
-    rewriter.startRootUpdate(op);
-    auto result = fir::NameUniquer::deconstruct(
-        op.getFuncname().getRootReference().getValue());
-    if (fir::NameUniquer::isExternalFacingUniquedName(result))
-      op.setFuncnameAttr(
-          SymbolRefAttr::get(op.getContext(), mangleExternalName(result)));
-    rewriter.finalizeRootUpdate(op);
-    return success();
-  }
-};
-
 class ExternalNameConversionPass
     : public fir::ExternalNameConversionBase<ExternalNameConversionPass> {
 public:
   mlir::ModuleOp getModule() { return getOperation(); }
   void runOnOperation() override;
 };
 } // namespace
 
 void ExternalNameConversionPass::runOnOperation() {
   auto op = getOperation();
   auto *context = &getContext();
 
   mlir::RewritePatternSet patterns(context);
   patterns.insert<MangleNameOnCallOp, MangleNameOnCallOp, MangleNameOnFuncOp,
-                  MangleNameForCommonBlock, MangleNameOnAddrOfOp,
-                  MangleNameOnEmboxProcOp>(context);
+                  MangleNameForCommonBlock, MangleNameOnAddrOfOp>(context);
 
   ConversionTarget target(*context);
   target.addLegalDialect<fir::FIROpsDialect, LLVM::LLVMDialect,
                          acc::OpenACCDialect, omp::OpenMPDialect>();
 
   target.addDynamicallyLegalOp<fir::CallOp>([](fir::CallOp op) {
     if (op.getCallee().hasValue())
       return !fir::NameUniquer::needExternalNameMangling(
return !fir::NameUniquer::needExternalNameMangling(
         op.getSymref().getRootReference().getValue());
   });
 
   target.addDynamicallyLegalOp<fir::AddrOfOp>([](fir::AddrOfOp op) {
     return !fir::NameUniquer::needExternalNameMangling(
         op.getSymbol().getRootReference().getValue());
   });
 
-  target.addDynamicallyLegalOp<fir::EmboxProcOp>([](fir::EmboxProcOp op) {
-    return !fir::NameUniquer::needExternalNameMangling(
-        op.getFuncname().getRootReference().getValue());
-  });
-
   if (failed(applyPartialConversion(op, target, std::move(patterns))))
     signalPassFailure();
 }
 
 std::unique_ptr<mlir::Pass> fir::createExternalNameConversionPass() {
   return std::make_unique<ExternalNameConversionPass>();
 }

flang/test/Fir/Todo/emboxproc.fir

-// RUN: %not_todo_cmd fir-opt --fir-to-llvm-ir="target=x86_64-unknown-linux-gnu" %s 2>&1 | FileCheck %s
-
-// Test `fir.emboxproc` conversion to llvm.
-// Not implemented yet.
-
-func @emboxproc_test() {
-  %host_vars = fir.alloca tuple<i32,f64>
-// CHECK: not yet implemented fir.emboxproc codegen
-  %bproc = fir.emboxproc @method_impl, %host_vars : ((i32) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(i32) -> ()>
-  return
-}

flang/test/Fir/external-mangling-emboxproc.fir

 // RUN: fir-opt --external-name-interop %s | FileCheck %s
 
 func @_QPfoo() {  
   %e6 = fir.alloca tuple<i32,f64>
-  %0 = fir.emboxproc @_QPfoo_impl, %e6 : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>  
+  %ao = fir.address_of(@_QPfoo_impl) : (!fir.box<!fir.type<derived3{f:f32}>>) -> ()
+  %0 = fir.emboxproc %ao, %e6 : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
   return
 }
 func private @_QPfoo_impl(!fir.ref<i32>)
 
-// CHECK: %{{.*}}= fir.emboxproc @foo_impl_
+// CHECK: fir.address_of(@foo_impl_)

flang/test/Fir/fir-ops.fir

 // CHECK: [[VAL_5:%.*]] = fir.allocmem !fir.array<100xf32>
 // CHECK: [[VAL_6:%.*]] = fir.embox [[VAL_5]] : (!fir.heap<!fir.array<100xf32>>) -> !fir.box<!fir.array<100xf32>>
   fir.store %3 to %2 : !fir.ref<i32>
   %4 = fir.undefined i32
   %5 = fir.allocmem !fir.array<100xf32>
   %6 = fir.embox %5 : (!fir.heap<!fir.array<100xf32>>) -> !fir.box<!fir.array<100xf32>>
 
 // CHECK: [[VAL_7:%.*]] = fir.box_addr [[VAL_6]] : (!fir.box<!fir.array<100xf32>>) -> !fir.ref<!fir.array<100xf32>>
+  %7 = fir.box_addr %6 : (!fir.box<!fir.array<100xf32>>) -> !fir.ref<!fir.array<100xf32>>
+// CHECK: %[[WAL_2:.*]] = fir.undefined !fir.boxproc<() -> ()>
+  %ba1 = fir.undefined !fir.boxproc<() -> ()>
+// CHECK: %{{.*}} = fir.box_addr %[[WAL_2]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+  %ba2 = fir.box_addr %ba1 : (!fir.boxproc<() -> ()>) -> (() -> ())
+  %ba3 = fir.undefined !fir.boxchar<1>
+// CHECK: %{{.*}} = fir.box_addr %{{.*}} : (!fir.boxchar<1>) -> !fir.ref<!fir.char<1>>
+  %ba4 = fir.box_addr %ba3 : (!fir.boxchar<1>) -> !fir.ref<!fir.char<1>>
+  %c0 = arith.constant 0 : index
+  %d1:3 = fir.box_dims %6, %c0 : (!fir.box<!fir.array<100xf32>>, index) -> (index, index, index)
 // CHECK: [[VAL_8:%.*]] = arith.constant 0 : index
 // CHECK: [[VAL_9:%.*]]:3 = fir.box_dims [[VAL_6]], [[VAL_8]] : (!fir.box<!fir.array<100xf32>>, index) -> (index, index, index)
 // CHECK: fir.call @print_index3([[VAL_9]]#0, [[VAL_9]]#1, [[VAL_9]]#2) : (index, index, index) -> ()
 // CHECK: [[VAL_10:%.*]] = fir.call @it1() : () -> !fir.int<4>
-  %7 = fir.box_addr %6 : (!fir.box<!fir.array<100xf32>>) -> !fir.ref<!fir.array<100xf32>>
-  %c0 = arith.constant 0 : index
-  %d1:3 = fir.box_dims %6, %c0 : (!fir.box<!fir.array<100xf32>>, index) -> (index, index, index)
   fir.call @print_index3(%d1#0, %d1#1, %d1#2) : (index, index, index) -> ()
   %8 = fir.call @it1() : () -> !fir.int<4>
 
 // CHECK: [[VAL_11:%.*]] = fir.box_elesize [[VAL_6]] : (!fir.box<!fir.array<100xf32>>) -> i64
 // CHECK: [[VAL_12:%.*]] = fir.box_isalloc [[VAL_6]] : (!fir.box<!fir.array<100xf32>>) -> i1
 // CHECK: [[VAL_13:%.*]] = fir.box_isarray [[VAL_6]] : (!fir.box<!fir.array<100xf32>>) -> i1
 // CHECK: [[VAL_14:%.*]] = fir.box_isptr [[VAL_6]] : (!fir.box<!fir.array<100xf32>>) -> i1
 // CHECK: [[VAL_15:%.*]] = fir.box_rank [[VAL_6]] : (!fir.box<!fir.array<100xf32>>) -> i64

 // CHECK: [[VAL_48:%.*]] = fir.undefined !fir.type<qq2{f1:i32,f2:f64}>
 // CHECK: [[VAL_49:%.*]] = arith.constant 0 : i32
 // CHECK: [[VAL_50:%.*]] = arith.constant 12 : i32
 // CHECK: [[VAL_51:%.*]] = fir.insert_value [[VAL_48]], [[VAL_50]], [0 : i32] : (!fir.type<qq2{f1:i32,f2:f64}>, i32) -> !fir.type<qq2{f1:i32,f2:f64}>
 // CHECK: [[VAL_52:%.*]] = arith.constant 1 : i32
 // CHECK: [[VAL_53:%.*]] = arith.constant 4.213000e+01 : f64
 // CHECK: [[VAL_54:%.*]] = fir.insert_value [[VAL_48]], [[VAL_53]], [1 : i32] : (!fir.type<qq2{f1:i32,f2:f64}>, f64) -> !fir.type<qq2{f1:i32,f2:f64}>
 // CHECK: fir.store [[VAL_54]] to [[VAL_39]] : !fir.ref<!fir.type<qq2{f1:i32,f2:f64}>>
-// CHECK: [[VAL_55:%.*]] = fir.emboxproc @method_impl, [[VAL_41]] : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32, f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
+// CHECK: %[[WAL_1:.*]] = fir.address_of(@method_impl)
+// CHECK: [[VAL_55:%.*]] = fir.emboxproc %[[WAL_1]], [[VAL_41]] : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32, f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
 // CHECK: [[VAL_56:%.*]], [[VAL_57:%.*]] = fir.unboxproc [[VAL_55]] : (!fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>) -> ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<!fir.type<qq2{f1:i32,f2:f64}>>>)
 // CHECK: [[VAL_58:%.*]] = fir.call @box2() : () -> !fir.boxproc<(i32, i32) -> i64>
 // CHECK: [[VAL_59:%.*]], [[VAL_60:%.*]] = fir.unboxproc [[VAL_58]] : (!fir.boxproc<(i32, i32) -> i64>) -> ((i32, i32) -> i64, !fir.ref<tuple<!fir.type<qq1{f1:i32}>>>)
 // CHECK: [[VAL_61:%.*]] = fir.load [[VAL_60]] : !fir.ref<tuple<!fir.type<qq1{f1:i32}>>>
 // CHECK: fir.call @store_tuple([[VAL_61]]) : (tuple<!fir.type<qq1{f1:i32}>>) -> ()
 // CHECK: return
 // CHECK: }
   %0 = fir.alloca i32
   %d6 = fir.alloca !fir.type<qq2{f1:i32,f2:f64}>
   %d3 = fir.alloca !fir.char<1>
   %e6 = fir.alloca tuple<i32,f64>
   %1 = fir.embox %0 : (!fir.ref<i32>) -> !fir.box<i32>
   %c8 = arith.constant 8 : i32
   %3 = fir.undefined !fir.char<1>
   %4 = fir.emboxchar %d3, %c8 : (!fir.ref<!fir.char<1>>, i32) -> !fir.boxchar<1>
   %5:2 = fir.unboxchar %4 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1>>, i32)
   %6 = fir.undefined !fir.type<qq2{f1:i32,f2:f64}>
   %z = arith.constant 0 : i32
   %c12 = arith.constant 12 : i32
   %a2 = fir.insert_value %6, %c12, [0 : i32] : (!fir.type<qq2{f1:i32,f2:f64}>, i32) -> !fir.type<qq2{f1:i32,f2:f64}>
   %z1 = arith.constant 1 : i32
   %c42 = arith.constant 42.13 : f64
   %a3 = fir.insert_value %6, %c42, [1 : i32] : (!fir.type<qq2{f1:i32,f2:f64}>, f64) -> !fir.type<qq2{f1:i32,f2:f64}>
   fir.store %a3 to %d6 : !fir.ref<!fir.type<qq2{f1:i32,f2:f64}>>
-  %7 = fir.emboxproc @method_impl, %e6 : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
+  %mi = fir.address_of(@method_impl) : (!fir.box<!fir.type<derived3{f:f32}>>) -> ()
+  %7 = fir.emboxproc %mi, %e6 : ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<i32,f64>>) -> !fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>
   %8:2 = fir.unboxproc %7 : (!fir.boxproc<(!fir.box<!fir.type<derived3{f:f32}>>) -> ()>) -> ((!fir.box<!fir.type<derived3{f:f32}>>) -> (), !fir.ref<tuple<!fir.type<qq2{f1:i32,f2:f64}>>>)
   %9 = fir.call @box2() : () -> !fir.boxproc<(i32, i32) -> i64>
   %10:2 = fir.unboxproc %9 : (!fir.boxproc<(i32, i32) -> i64>) -> ((i32, i32) -> i64, !fir.ref<tuple<!fir.type<qq1{f1:i32}>>>)
   %11 = fir.load %10#1 : !fir.ref<tuple<!fir.type<qq1{f1:i32}>>>
   fir.call @store_tuple(%11) : (tuple<!fir.type<qq1{f1:i32}>>) -> ()
   return
 }
 

flang/test/Lower/Intrinsics/len.f90

 ! RUN: bbc -emit-fir %s -o - | FileCheck %s
 
 ! CHECK-LABEL: len_test
 subroutine len_test(i, c)
-    integer :: i
-    character(*) :: c
-    ! CHECK: %[[c:.*]]:2 = fir.unboxchar %arg1
-    ! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32
-    ! CHECK: fir.store %[[xx]] to %arg0
-    i = len(c)
-  end subroutine
-  
-  ! CHECK-LABEL: len_test_array
-  ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"}, %[[arg1:.*]]: !fir.boxchar<1> {fir.bindc_name = "c"}
-  subroutine len_test_array(i, c)
-    integer :: i
-    character(*) :: c(100)
-    ! CHECK: %[[c:.*]]:2 = fir.unboxchar %[[arg1]]
-    ! CHECK: %[[xx:.*]] = fir.convert %[[c]]#1 : (index) -> i32
-    ! CHECK: fir.store %[[xx]] to %[[arg0]]
-    i = len(c)
-  end subroutine
-  
-  ! CHECK-LABEL: func @_QPlen_test_assumed_shape_array(
-  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
-  ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.box<!fir.array<?x!fir.char<1,?>>> {fir.bindc_name = "c"}) {
-  subroutine len_test_assumed_shape_array(i, c)
-    integer :: i
-    character(*) :: c(:)
-  ! CHECK:  %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box<!fir.array<?x!fir.char<1,?>>>) -> index
-  ! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (index) -> i32
-  ! CHECK:  fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref<i32>
-    i = len(c)
-  end subroutine
-  
-  ! CHECK-LABEL: func @_QPlen_test_array_alloc(
-  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
-  ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "c"}) {
-  subroutine len_test_array_alloc(i, c)
-    integer :: i
-    character(:), allocatable :: c(:)
-  ! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
-  ! CHECK:  %[[VAL_3:.*]] = fir.box_elesize %[[VAL_2]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>) -> index
-  ! CHECK:  %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (index) -> i32
-  ! CHECK:  fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref<i32>
-    i = len(c)
-  end subroutine
-  
-  ! CHECK-LABEL: func @_QPlen_test_array_local_alloc(
-  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"})
-  subroutine len_test_array_local_alloc(i)
-    integer :: i
-    character(:), allocatable :: c(:)
-  ! CHECK:  %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFlen_test_array_local_allocEc.len"}
-  ! CHECK:  %[[VAL_7:.*]] = arith.constant 10 : i32
-  ! CHECK:  %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (i32) -> index
-  ! CHECK:  fir.store %[[VAL_10]] to %[[VAL_5]] : !fir.ref<index>
-    allocate(character(10):: c(100))
-  ! CHECK:  %[[VAL_13:.*]] = fir.load %[[VAL_5]] : !fir.ref<index>
-  ! CHECK:  %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (index) -> i32
-  ! CHECK:  fir.store %[[VAL_14]] to %[[VAL_0]] : !fir.ref<i32>
-    i = len(c)
-  end subroutine
-  
-  ! CHECK-LABEL: func @_QPlen_test_alloc_explicit_len(
-  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
-  ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<i32> {fir.bindc_name = "n"},
-  ! CHECK-SAME:  %[[VAL_2:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>> {fir.bindc_name = "c"}) {
-  subroutine len_test_alloc_explicit_len(i, n, c)
-    integer :: i
-    integer :: n
-    character(n), allocatable :: c(:)
-  ! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
-  ! CHECK:  fir.store %[[VAL_3]] to %[[VAL_0]] : !fir.ref<i32>
-    i = len(c)
-  end subroutine
+! CHECK:  %[[c0_i32:.*]] = arith.constant 0 : i32
+! CHECK:  %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32
+! CHECK:  %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32
+! CHECK:  fir.store %[[len]] to %[[VAL_0]] : !fir.ref<i32>
+  i = len(c)
+end subroutine
+
+! CHECK-LABEL: func @_QPlen_test_pointer_explicit_len(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
+! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<i32> {fir.bindc_name = "n"},
+subroutine len_test_pointer_explicit_len(i, n, c)
+  integer :: i
+  integer :: n
+  character(n), pointer :: c(:)
+! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
+! CHECK:  %[[c0_i32:.*]] = arith.constant 0 : i32
+! CHECK:  %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32
+! CHECK:  %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32
+! CHECK:  fir.store %[[len]] to %[[VAL_0]] : !fir.ref<i32>
+  i = len(c)
+end subroutine
+
+! CHECK-LABEL: func @_QPlen_test_assumed_shape_explicit_len(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "i"},
+! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<i32> {fir.bindc_name = "n"},
+subroutine len_test_assumed_shape_explicit_len(i, n, c)
+  integer :: i
+  integer :: n
+  character(n) :: c(:)
+! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
+! CHECK:  %[[c0_i32:.*]] = arith.constant 0 : i32
+! CHECK:  %[[cmp:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[c0_i32]] : i32
+! CHECK:  %[[len:.*]] = arith.select %[[cmp]], %[[VAL_3]], %[[c0_i32]] : i32
+! CHECK:  fir.store %[[len]] to %[[VAL_0]] : !fir.ref<i32>

flang/test/Lower/allocatable-assignment.f90

 ! Test allocatable assignments
 ! RUN: bbc -emit-fir %s -o - | FileCheck %s
 
 module alloc_assign
+  type t
+    integer :: i
+  end type
 contains
 
 ! -----------------------------------------------------------------------------
 !            Test simple scalar RHS
 ! -----------------------------------------------------------------------------
 
 ! CHECK-LABEL: func @_QMalloc_assignPtest_simple_scalar(
 ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<f32>>>{{.*}}) {

 end subroutine
 
 ! CHECK-LABEL: func @_QMalloc_assignPtest_dyn_char_scalar(
 ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>{{.*}},
 ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<i32>{{.*}}) {
 subroutine test_dyn_char_scalar(x, n)
   integer :: n
   character(n), allocatable  :: x
-! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
+! CHECK:  %[[VAL_2A:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
+! CHECK:  %[[c0_i32:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_2B:.*]] = arith.cmpi sgt, %[[VAL_2A]], %[[c0_i32]] : i32
+! CHECK:  %[[VAL_2:.*]] = arith.select %[[VAL_2B]], %[[VAL_2A]], %[[c0_i32]] : i32
 ! CHECK:  %[[VAL_3:.*]] = fir.address_of(@_QQcl.48656C6C6F20776F726C6421) : !fir.ref<!fir.char<1,12>>
 ! CHECK:  %[[VAL_4:.*]] = arith.constant 12 : index
 ! CHECK:  %[[VAL_5:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
 ! CHECK:  %[[VAL_6:.*]] = fir.box_addr %[[VAL_5]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
 ! CHECK:  %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (!fir.heap<!fir.char<1,?>>) -> i64
 ! CHECK:  %[[VAL_8:.*]] = arith.constant 0 : i64
 ! CHECK:  %[[VAL_9:.*]] = arith.cmpi ne, %[[VAL_7]], %[[VAL_8]] : i64
 ! CHECK:  %[[VAL_10:.*]]:2 = fir.if %[[VAL_9]] -> (i1, !fir.heap<!fir.char<1,?>>) {

 ! CHECK:      fir.freemem %[[VAL_6]]
 ! CHECK:    }
 ! CHECK:    %[[VAL_40:.*]] = fir.embox %[[VAL_10]]#1 typeparams %[[VAL_39]] : (!fir.heap<!fir.char<1,?>>, index) -> !fir.box<!fir.heap<!fir.char<1,?>>>
 ! CHECK:    fir.store %[[VAL_40]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
 ! CHECK:  }
   x = "Hello world!"
 end subroutine
 
+! CHECK-LABEL: func @_QMalloc_assignPtest_derived_scalar(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>>{{.*}},
+! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<!fir.type<_QMalloc_assignTt{i:i32}>>{{.*}}) {
+subroutine test_derived_scalar(x, s)
+  type(t), allocatable  :: x
+  type(t) :: s
+  x = s
+! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>>
+! CHECK:  %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>) -> !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
+! CHECK:  %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>) -> 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<!fir.type<_QMalloc_assignTt{i:i32}>>) {
+! CHECK:    %[[VAL_8:.*]] = arith.constant false
+! CHECK:    %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>) {
+! CHECK:      %[[VAL_10:.*]] = fir.allocmem !fir.type<_QMalloc_assignTt{i:i32}> {uniq_name = ".auto.alloc"}
+! CHECK:      fir.result %[[VAL_10]] : !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
+! CHECK:    } else {
+! CHECK:      fir.result %[[VAL_3]] : !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
+! CHECK:    }
+! CHECK:    fir.result %[[VAL_8]], %[[VAL_11:.*]] : i1, !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
+! CHECK:  } else {
+! CHECK:    %[[VAL_12:.*]] = arith.constant true
+! CHECK:    %[[VAL_13:.*]] = fir.allocmem !fir.type<_QMalloc_assignTt{i:i32}> {uniq_name = ".auto.alloc"}
+! CHECK:    fir.result %[[VAL_12]], %[[VAL_13]] : i1, !fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>
+! CHECK:  }
+! CHECK:  %[[VAL_14:.*]] = fir.field_index i, !fir.type<_QMalloc_assignTt{i:i32}>
+! CHECK:  %[[VAL_15:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_14]] : (!fir.ref<!fir.type<_QMalloc_assignTt{i:i32}>>, !fir.field) -> !fir.ref<i32>
+! CHECK:  %[[VAL_16:.*]] = fir.coordinate_of %[[VAL_7]]#1, %[[VAL_14]] : (!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>, !fir.field) -> !fir.ref<i32>
+! CHECK:  %[[VAL_17:.*]] = fir.load %[[VAL_15]] : !fir.ref<i32>
+! CHECK:  fir.store %[[VAL_17]] to %[[VAL_16]] : !fir.ref<i32
+! CHECK:  fir.if %[[VAL_7]]#0 {
+! CHECK:    fir.if %[[VAL_6]] {
+! CHECK:      fir.freemem %[[VAL_3]]
+! CHECK:    }
+! CHECK:    %[[VAL_19:.*]] = fir.embox %[[VAL_7]]#1 : (!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>) -> !fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>
+! CHECK:    fir.store %[[VAL_19]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMalloc_assignTt{i:i32}>>>>
+! CHECK:  }
+end subroutine
+
 ! -----------------------------------------------------------------------------
 !            Test numeric/logical array RHS
 ! -----------------------------------------------------------------------------
 
 ! CHECK-LABEL: func @_QMalloc_assignPtest_from_cst_shape_array(
 ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>{{.*}},
 ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<!fir.array<2x3xf32>>{{.*}}) {
 subroutine test_from_cst_shape_array(x, y)

 ! CHECK:    }
 ! CHECK:    %[[VAL_49:.*]] = fir.shape_shift %[[VAL_3]], %[[VAL_9]]#1, %[[VAL_5]], %[[VAL_11]]#1 : (index, index, index, index) -> !fir.shapeshift<2>
 ! CHECK:    %[[VAL_50:.*]] = fir.embox %[[VAL_17]]#1(%[[VAL_49]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shapeshift<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
 ! CHECK:    fir.store %[[VAL_50]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
 ! CHECK:  }
   x = y
 end subroutine
 
+! CHECK-LABEL: func @_QMalloc_assignPtest_runtime_shape(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>{{.*}}) {
+subroutine test_runtime_shape(x)
+  real, allocatable  :: x(:, :)
+  interface
+   function return_pointer()
+     real, pointer :: return_pointer(:, :)
+   end function
+  end interface
+! CHECK:  %[[VAL_1:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?xf32>>> {bindc_name = ".result"}
+! CHECK:  %[[VAL_2:.*]] = fir.call @_QPreturn_pointer() : () -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+! CHECK:  fir.save_result %[[VAL_2]] to %[[VAL_1]] : !fir.box<!fir.ptr<!fir.array<?x?xf32>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+! CHECK:  %[[VAL_4:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_6:.*]] = arith.constant 1 : index
+! CHECK:  %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_6]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_8:.*]] = fir.shift %[[VAL_5]]#0, %[[VAL_7]]#0 : (index, index) -> !fir.shift<2>
+! CHECK:  %[[VAL_10:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_10]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_12:.*]] = arith.constant 1 : index
+! CHECK:  %[[VAL_13:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_12]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_9:.*]] = fir.array_load %[[VAL_3]](%[[VAL_8]]) : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>, !fir.shift<2>) -> !fir.array<?x?xf32>
+! CHECK:  %[[VAL_14:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
+! CHECK:  %[[VAL_15:.*]] = fir.box_addr %[[VAL_14]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>) -> !fir.heap<!fir.array<?x?xf32>>
+! CHECK:  %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.heap<!fir.array<?x?xf32>>) -> i64
+! CHECK:  %[[VAL_17:.*]] = arith.constant 0 : i64
+! CHECK:  %[[VAL_18:.*]] = arith.cmpi ne, %[[VAL_16]], %[[VAL_17]] : i64
+! CHECK:  %[[VAL_19:.*]]:2 = fir.if %[[VAL_18]] -> (i1, !fir.heap<!fir.array<?x?xf32>>) {
+! CHECK:    %[[VAL_20:.*]] = arith.constant false
+! CHECK:    %[[VAL_21:.*]] = arith.constant 0 : index
+! CHECK:    %[[VAL_22:.*]]:3 = fir.box_dims %[[VAL_14]], %[[VAL_21]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
+! CHECK:    %[[VAL_23:.*]] = arith.constant 1 : index
+! CHECK:    %[[VAL_24:.*]]:3 = fir.box_dims %[[VAL_14]], %[[VAL_23]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
+! CHECK:    %[[VAL_25:.*]] = arith.cmpi ne, %[[VAL_22]]#1, %[[VAL_11]]#1 : index
+! CHECK:    %[[VAL_26:.*]] = arith.select %[[VAL_25]], %[[VAL_25]], %[[VAL_20]] : i1
+! CHECK:    %[[VAL_27:.*]] = arith.cmpi ne, %[[VAL_24]]#1, %[[VAL_13]]#1 : index
+! CHECK:    %[[VAL_28:.*]] = arith.select %[[VAL_27]], %[[VAL_27]], %[[VAL_26]] : i1
+! CHECK:    %[[VAL_29:.*]] = fir.if %[[VAL_28]] -> (!fir.heap<!fir.array<?x?xf32>>) {
+! CHECK:      %[[VAL_30:.*]] = fir.allocmem !fir.array<?x?xf32>, %[[VAL_11]]#1, %[[VAL_13]]#1 {uniq_name = ".auto.alloc"}
+! CHECK:      fir.result %[[VAL_30]] : !fir.heap<!fir.array<?x?xf32>>
+! CHECK:    } else {
+! CHECK:      fir.result %[[VAL_15]] : !fir.heap<!fir.array<?x?xf32>>
+! CHECK:    }
+! CHECK:    fir.result %[[VAL_28]], %[[VAL_31:.*]] : i1, !fir.heap<!fir.array<?x?xf32>>
+! CHECK:  } else {
+! CHECK:    %[[VAL_32:.*]] = arith.constant true
+! CHECK:    %[[VAL_33:.*]] = fir.allocmem !fir.array<?x?xf32>, %[[VAL_11]]#1, %[[VAL_13]]#1 {uniq_name = ".auto.alloc"}
+! CHECK:    fir.result %[[VAL_32]], %[[VAL_33]] : i1, !fir.heap<!fir.array<?x?xf32>>
+! CHECK:  }
+
+! CHECK-NOT: fir.call @_QPreturn_pointer()
+! CHECK:  %[[VAL_34:.*]] = fir.shape %[[VAL_11]]#1, %[[VAL_13]]#1 : (index, index) -> !fir.shape<2>
+! CHECK:  %[[VAL_35:.*]] = fir.array_load %[[VAL_19]]#1(%[[VAL_34]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.array<?x?xf32>
+! normal array assignment ....
+! CHECK-NOT: fir.call @_QPreturn_pointer()
+! CHECK:  fir.array_merge_store %{{.*}}, %{{.*}} to %[[VAL_19]]#1 : !fir.array<?x?xf32>, !fir.array<?x?xf32>, !fir.heap<!fir.array<?x?xf32>>
+! CHECK-NOT: fir.call @_QPreturn_pointer()
+
+! CHECK:  fir.if %[[VAL_19]]#0 {
+! CHECK:    fir.if %[[VAL_18]] {
+! CHECK:      fir.freemem %[[VAL_15]]
+! CHECK:    }
+! CHECK:    %[[VAL_56:.*]] = fir.shape %[[VAL_11]]#1, %[[VAL_13]]#1 : (index, index) -> !fir.shape<2>
+! CHECK:    %[[VAL_57:.*]] = fir.embox %[[VAL_19]]#1(%[[VAL_56]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
+! CHECK:    fir.store %[[VAL_57]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
+! CHECK:  }
+  x = return_pointer()
+end subroutine
+
 ! CHECK-LABEL: func @_QMalloc_assignPtest_scalar_rhs(
 subroutine test_scalar_rhs(x, y)
   real, allocatable  :: x(:)
   real :: y
   ! CHECK: fir.if %{{.*}} -> {{.*}} {
   ! CHECK:   fir.if %false -> {{.*}} {
   ! CHECK:   }
   ! CHECK: } else {
   ! CHECK: %[[error_msg_addr:.*]] = fir.address_of(@[[error_message:.*]]) : !fir.ref<!fir.char<1,76>>
   ! CHECK: %[[msg_addr_cast:.*]] = fir.convert %[[error_msg_addr]] : (!fir.ref<!fir.char<1,76>>) -> !fir.ref<i8>
   ! CHECK: %15 = fir.call @_FortranAReportFatalUserError(%[[msg_addr_cast]], %{{.*}}, %{{.*}}) : (!fir.ref<i8>, !fir.ref<i8>, i32) -> none
   ! CHECK-NOT: allocmem
   ! CHECK: }
   x = y
 end subroutine
 
 ! -----------------------------------------------------------------------------
 !            Test character array RHS
 ! -----------------------------------------------------------------------------
 
+
+! Hit TODO: gathering lhs length in array expression
+!subroutine test_deferred_char_rhs_scalar(x)
+!  character(:), allocatable  :: x(:)
+!  x = "Hello world!"
+!end subroutine
+
 ! CHECK: func @_QMalloc_assignPtest_cst_char_rhs_scalar(
 subroutine test_cst_char_rhs_scalar(x)
   character(10), allocatable  :: x(:)
   x = "Hello world!"
   ! CHECK: fir.if %{{.*}} -> {{.*}} {
   ! CHECK:   fir.if %false -> {{.*}} {
   ! CHECK:   }
   ! CHECK: } else {
-  ! CHECK: fir.call @_FortranAReportFatalUserError
+  ! TODO: runtime error if unallocated
   ! CHECK-NOT: allocmem
   ! CHECK: }
 end subroutine
 
 ! CHECK: func @_QMalloc_assignPtest_dyn_char_rhs_scalar(
 subroutine test_dyn_char_rhs_scalar(x, n)
   integer :: n
   character(n), allocatable  :: x(:)
   x = "Hello world!"
   ! CHECK: fir.if %{{.*}} -> {{.*}} {
   ! CHECK:   fir.if %false -> {{.*}} {
   ! CHECK:   }
   ! CHECK: } else {
-  ! CHECK: fir.call @_FortranAReportFatalUserError
+  ! TODO: runtime error if unallocated
   ! CHECK-NOT: allocmem
   ! CHECK: }
 end subroutine
 
+! Hit TODO: gathering lhs length in array expression
+!subroutine test_deferred_char(x, c)
+!  character(:), allocatable  :: x(:)
+!  character(12) :: c(20)
+!  x = "Hello world!"
+!end subroutine
+
 ! CHECK-LABEL: func @_QMalloc_assignPtest_cst_char(
 ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>{{.*}},
 ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.boxchar<1>{{.*}}) {
 subroutine test_cst_char(x, c)
   character(10), allocatable  :: x(:)
   character(12) :: c(20)
 ! CHECK:  %[[VAL_2:.*]]:2 = fir.unboxchar %[[VAL_1]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
 ! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_2]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<20x!fir.char<1,12>>>

 ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<i32>{{.*}}, %[[VAL_2:.*]]: !fir.boxchar<1>{{.*}}) {
 subroutine test_dyn_char(x, n, c)
   integer :: n
   character(n), allocatable  :: x(:)
   character(*) :: c(20)
 ! CHECK:  %[[VAL_3:.*]]:2 = fir.unboxchar %[[VAL_2]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
 ! CHECK:  %[[VAL_4:.*]] = fir.convert %[[VAL_3]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<20x!fir.char<1,?>>>
 ! CHECK:  %[[VAL_5_0:.*]] = arith.constant 20 : index
-! CHECK:  %[[VAL_6:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
+! CHECK:  %[[VAL_6A:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
+! CHECK:  %[[c0_i32:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_6B:.*]] = arith.cmpi sgt, %[[VAL_6A]], %[[c0_i32]] : i32
+! CHECK:  %[[VAL_6:.*]] = arith.select %[[VAL_6B]], %[[VAL_6A]], %[[c0_i32]] : i32
 ! CHECK:  %[[VAL_5:.*]] = arith.constant 20 : index
 ! CHECK:  %[[VAL_7:.*]] = fir.shape %[[VAL_5_0]] : (index) -> !fir.shape<1>
 ! CHECK:  %[[VAL_9:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
 ! CHECK:  %[[VAL_10:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>) -> !fir.heap<!fir.array<?x!fir.char<1,?>>>
 ! CHECK:  %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.heap<!fir.array<?x!fir.char<1,?>>>) -> i64
 ! CHECK:  %[[VAL_12:.*]] = arith.constant 0 : i64
 ! CHECK:  %[[VAL_13:.*]] = arith.cmpi ne, %[[VAL_11]], %[[VAL_12]] : i64
 ! CHECK:  %[[VAL_14:.*]]:2 = fir.if %[[VAL_13]] -> (i1, !fir.heap<!fir.array<?x!fir.char<1,?>>>) {

 ! CHECK:    }
 ! CHECK:    %[[VAL_40:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1>
 ! CHECK:    %[[VAL_41:.*]] = fir.embox %[[VAL_14]]#1(%[[VAL_40]]) typeparams %[[VAL_39]] : (!fir.heap<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, index) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>
 ! CHECK:    fir.store %[[VAL_41]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
 ! CHECK:  }
   x = c
 end subroutine
 
+! CHECK-LABEL: func @_QMalloc_assignPtest_derived_with_init
+subroutine test_derived_with_init(x, y)
+  type t 
+    integer, allocatable :: a(:)
+  end type                                                                                     
+  type(t), allocatable :: x                                                                    
+  type(t) :: y                                                                                 
+  ! The allocatable component of `x` need to be initialized
+  ! during the automatic allocation (setting its rank and allocation
+  ! status) before it is assigned with the component of `y` 
+  x = y
+! CHECK:  fir.if %{{.*}} {
+! CHECK:    %[[VAL_11:.*]] = fir.allocmem !fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}> {uniq_name = ".auto.alloc"}
+! CHECK:    %[[VAL_12:.*]] = fir.embox %[[VAL_11]] : (!fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<!fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>>
+! CHECK:    %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!fir.box<!fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>>) -> !fir.box<none>
+! CHECK:    fir.call @_FortranAInitialize(%[[VAL_15]], %{{.*}}, %{{.*}}) : (!fir.box<none>, !fir.ref<i8>, i32) -> none
+! CHECK:    fir.result %[[VAL_11]] : !fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+! CHECK:  } else {
+! CHECK:    fir.result %{{.*}} : !fir.heap<!fir.type<_QMalloc_assignFtest_derived_with_initTt{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+! CHECK:  }
+end subroutine
+
+! CHECK-LABEL: func @_QMalloc_assignPtest_vector_subscript(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>> {fir.bindc_name = "x"},
+! CHECK-SAME: %[[VAL_1:.*]]: !fir.box<!fir.array<?xi32>> {fir.bindc_name = "y"},
+! CHECK-SAME: %[[VAL_2:.*]]: !fir.box<!fir.array<?xi32>> {fir.bindc_name = "v"}) {
+subroutine test_vector_subscript(x, y, v)
+  ! Test that the new shape is computed correctly in presence of
+  ! vector subscripts on the RHS and that it is used to allocate
+  ! the new storage and to drive the implicit loop.
+  integer, allocatable :: x(:)
+  integer :: y(:), v(:)
+  x = y(v)
+! CHECK:         %[[VAL_3:.*]] = arith.constant 1 : index
+! CHECK:         %[[VAL_4:.*]] = arith.constant 0 : index
+! CHECK:         %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_1]], %[[VAL_4]] : (!fir.box<!fir.array<?xi32>>, index) -> (index, index, index)
+! CHECK:         %[[VAL_6:.*]] = arith.constant 0 : index
+! CHECK:         %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_6]] : (!fir.box<!fir.array<?xi32>>, index) -> (index, index, index)
+! CHECK:         %[[VAL_8:.*]] = fir.array_load %[[VAL_2]] : (!fir.box<!fir.array<?xi32>>) -> !fir.array<?xi32>
+! CHECK:         %[[VAL_9:.*]] = arith.cmpi sgt, %[[VAL_7]]#1, %[[VAL_5]]#1 : index
+! CHECK:         %[[VAL_10:.*]] = arith.select %[[VAL_9]], %[[VAL_5]]#1, %[[VAL_7]]#1 : index
+! CHECK:         fir.if {{.*}} {
+! CHECK:           %[[VAL_18:.*]] = arith.constant false
+! CHECK:           %[[VAL_20:.*]]:3 = fir.box_dims %{{.*}}, %{{.*}} : (!fir.box<!fir.heap<!fir.array<?xi32>>>, index) -> (index, index, index)
+! CHECK:           %[[VAL_21:.*]] = arith.cmpi ne, %[[VAL_20]]#1, %[[VAL_10]] : index
+! CHECK:           %[[VAL_22:.*]] = arith.select %[[VAL_21]], %[[VAL_21]], %[[VAL_18]] : i1
+! CHECK:           fir.if %[[VAL_22]] {{.*}} {
+! CHECK:             %[[VAL_24:.*]] = fir.allocmem !fir.array<?xi32>, %[[VAL_10]] {uniq_name = ".auto.alloc"}
+! CHECK:             fir.result %[[VAL_24]] : !fir.heap<!fir.array<?xi32>>
+! CHECK:           } else {
+! CHECK:             fir.result %{{.*}} : !fir.heap<!fir.array<?xi32>>
+! CHECK:           }
+! CHECK:           fir.result %{{.*}}, %{{.*}}
+! CHECK:         } else {
+! CHECK:           %[[VAL_27:.*]] = fir.allocmem !fir.array<?xi32>, %[[VAL_10]] {uniq_name = ".auto.alloc"}
+! CHECK:           fir.result %{{.*}}, %[[VAL_27]] : i1, !fir.heap<!fir.array<?xi32>>
+! CHECK:         }
+! CHECK:         %[[VAL_28:.*]] = fir.shape %[[VAL_10]] : (index) -> !fir.shape<1>
+! CHECK:         %[[VAL_29:.*]] = fir.array_load %[[VAL_30:.*]]#1(%[[VAL_28]]) : (!fir.heap<!fir.array<?xi32>>, !fir.shape<1>) -> !fir.array<?xi32>
+! CHECK:         %[[VAL_31:.*]] = arith.constant 1 : index
+! CHECK:         %[[VAL_32:.*]] = arith.constant 0 : index
+! CHECK:         %[[VAL_33:.*]] = arith.subi %[[VAL_10]], %[[VAL_31]] : index
+! CHECK:         %[[VAL_34:.*]] = fir.do_loop %[[VAL_35:.*]] = %[[VAL_32]] to %[[VAL_33]] step %[[VAL_31]] {{.*}} {
+! CHECK:         }
+end subroutine
+
+! CHECK: fir.global linkonce @[[error_message]] constant : !fir.char<1,76> {
+! CHECK:   %[[msg:.*]] = fir.string_lit "array left hand side must be allocated when the right hand side is a scalar\00"(76) : !fir.char<1,76>
+! CHECK:   fir.has_value %[[msg:.*]] : !fir.char<1,76>
+! CHECK: }
+
 end module
+
+!  use alloc_assign
+!  real :: y(2, 3) = reshape([1,2,3,4,5,6], [2,3])
+!  real, allocatable :: x (:, :)
+!  allocate(x(2,2))
+!  call test_with_lbounds(x, y) 
+!  print *, x(10, 20)
+!  print *, x
+!end

flang/test/Lower/allocatable-callee.f90

 
 ! CHECK-LABEL: func @_QPtest_char_scalar_explicit_dynamic(
 ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>{{.*}}, %[[arg1:.*]]: !fir.ref<i32>{{.*}})
 subroutine test_char_scalar_explicit_dynamic(c, n)
   integer :: n
   character(n), allocatable :: c
   external foo1
   ! Check that the length expr was evaluated before the execution parts.
-  ! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref<i32>
+  ! CHECK: %[[raw_len:.*]] = fir.load %arg1 : !fir.ref<i32>
+  ! CHECK:  %[[c0_i32:.*]] = arith.constant 0 : i32
+  ! CHECK:  %[[cmp:.*]] = arith.cmpi sgt, %[[raw_len]], %[[c0_i32]] : i32
+  ! CHECK:  %[[len:.*]] = arith.select %[[cmp]], %[[raw_len]], %[[c0_i32]] : i32
   n = n + 1
   ! CHECK: fir.store {{.*}} to %arg1 : !fir.ref<i32>
   call foo1(c)
   ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
   ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> !fir.heap<!fir.char<1,?>>
   ! CHECK-DAG: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.heap<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
   ! CHECK-DAG: %[[len_cast:.*]] = fir.convert %[[len]] : (i32) -> index
   ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len_cast]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>

 
 ! CHECK-LABEL: func @_QPtest_char_array_explicit_dynamic(
 ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>{{.*}}, %[[arg1:.*]]: !fir.ref<i32>{{.*}})
 subroutine test_char_array_explicit_dynamic(c, n)
   integer :: n
   character(n), allocatable :: c(:)
   external foo1
   ! Check that the length expr was evaluated before the execution parts.
-  ! CHECK: %[[len:.*]] = fir.load %arg1 : !fir.ref<i32>
+  ! CHECK: %[[raw_len:.*]] = fir.load %arg1 : !fir.ref<i32>
+  ! CHECK:  %[[c0_i32:.*]] = arith.constant 0 : i32
+  ! CHECK:  %[[cmp:.*]] = arith.cmpi sgt, %[[raw_len]], %[[c0_i32]] : i32
+  ! CHECK:  %[[len:.*]] = arith.select %[[cmp]], %[[raw_len]], %[[c0_i32]] : i32
   n = n + 1
   ! CHECK: fir.store {{.*}} to %arg1 : !fir.ref<i32>
   call foo1(c(1))
   ! CHECK: %[[box:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
   ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>) -> !fir.heap<!fir.array<?x!fir.char<1,?>>>
   ! [...] address computation
   ! CHECK: fir.coordinate_of
   ! CHECK-DAG: %[[len_cast:.*]] = fir.convert %[[len]] : (i32) -> index

flang/test/Lower/allocatable-runtime.f90

 ! RUN: bbc -emit-fir -use-alloc-runtime %s -o - | FileCheck %s
 
 ! Test lowering of allocatables using runtime for allocate/deallcoate statements.
 ! CHECK-LABEL: _QPfoo
 subroutine foo()
-    real, allocatable :: x(:), y(:, :), z
-    ! CHECK: %[[xBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xf32>>> {{{.*}}uniq_name = "_QFfooEx"}
-    ! CHECK-DAG: %[[xNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?xf32>>
-    ! CHECK-DAG: %[[xNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
-    ! CHECK: %[[xInitEmbox:.*]] = fir.embox %[[xNullAddr]](%[[xNullShape]]) : (!fir.heap<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?xf32>>>
-    ! CHECK: fir.store %[[xInitEmbox]] to %[[xBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
-  
-    ! CHECK: %[[yBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?xf32>>> {{{.*}}uniq_name = "_QFfooEy"}
-    ! CHECK-DAG: %[[yNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x?xf32>>
-    ! CHECK-DAG: %[[yNullShape:.*]] = fir.shape %c0{{.*}}, %c0{{.*}} : (index, index) -> !fir.shape<2>
-    ! CHECK: %[[yInitEmbox:.*]] = fir.embox %[[yNullAddr]](%[[yNullShape]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
-    ! CHECK: fir.store %[[yInitEmbox]] to %[[yBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
-  
-    ! CHECK: %[[zBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<f32>> {{{.*}}uniq_name = "_QFfooEz"}
-    ! CHECK: %[[zNullAddr:.*]] = fir.zero_bits !fir.heap<f32>
-    ! CHECK: %[[zInitEmbox:.*]] = fir.embox %[[zNullAddr]] : (!fir.heap<f32>) -> !fir.box<!fir.heap<f32>>
-    ! CHECK: fir.store %[[zInitEmbox]] to %[[zBoxAddr]] : !fir.ref<!fir.box<!fir.heap<f32>>>
-  
-    allocate(x(42:100), y(43:50, 51), z)
-    ! CHECK-DAG: %[[errMsg:.*]] = fir.absent !fir.box<none>
-    ! CHECK-DAG: %[[xlb:.*]] = arith.constant 42 : i32
-    ! CHECK-DAG: %[[xub:.*]] = arith.constant 100 : i32
-    ! CHECK-DAG: %[[xBoxCast2:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK-DAG: %[[xlbCast:.*]] = fir.convert %[[xlb]] : (i32) -> i64
-    ! CHECK-DAG: %[[xubCast:.*]] = fir.convert %[[xub]] : (i32) -> i64
-    ! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[xBoxCast2]], %c0{{.*}}, %[[xlbCast]], %[[xubCast]]) : (!fir.ref<!fir.box<none>>, i32, i64, i64) -> none
-    ! CHECK-DAG: %[[xBoxCast3:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK-DAG: %[[sourceFile:.*]] = fir.convert %{{.*}} -> !fir.ref<i8>
-    ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[xBoxCast3]], %false{{.*}}, %[[errMsg]], %[[sourceFile]], %{{.*}}) : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
-  
-    ! Simply check that we are emitting the right numebr of set bound for y and z. Otherwise, this is just like x.
-    ! CHECK: fir.convert %[[yBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableSetBounds
-    ! CHECK: fir.call @{{.*}}AllocatableSetBounds
-    ! CHECK: fir.call @{{.*}}AllocatableAllocate
-    ! CHECK: %[[zBoxCast:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK-NOT: fir.call @{{.*}}AllocatableSetBounds
-    ! CHECK: fir.call @{{.*}}AllocatableAllocate
-  
-    ! Check that y descriptor is read when referencing it.
-    ! CHECK: %[[yBoxLoad:.*]] = fir.load %[[yBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
-    ! CHECK: %[[yBounds1:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c0{{.*}} : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
-    ! CHECK: %[[yBounds2:.*]]:3 = fir.box_dims %[[yBoxLoad]], %c1{{.*}} : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>, index) -> (index, index, index)
-    ! CHECK: %[[yAddr:.*]] = fir.box_addr %[[yBoxLoad]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>) -> !fir.heap<!fir.array<?x?xf32>>
-    print *, x, y(45, 46), z
-  
-    deallocate(x, y, z)
-    ! CHECK: %[[xBoxCast4:.*]] = fir.convert %[[xBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[xBoxCast4]], {{.*}})
-    ! CHECK: %[[yBoxCast4:.*]] = fir.convert %[[yBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[yBoxCast4]], {{.*}})
-    ! CHECK: %[[zBoxCast4:.*]] = fir.convert %[[zBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[zBoxCast4]], {{.*}})
-  end subroutine
-  
-  ! test lowering of character allocatables
-  ! CHECK-LABEL: _QPchar_deferred(
-  subroutine char_deferred(n)
-    integer :: n
-    character(:), allocatable :: scalar, array(:)
-    ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFchar_deferredEscalar"}
-    ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,?>>
-    ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %c0{{.*}} : (!fir.heap<!fir.char<1,?>>, index) -> !fir.box<!fir.heap<!fir.char<1,?>>>
-    ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
-  
-    ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFchar_deferredEarray"}
-    ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,?>>>
-    ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
-    ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %c0{{.*}} : (!fir.heap<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, index) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>
-    ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
-  
-    allocate(character(10):: scalar, array(30))
-    ! CHECK-DAG: %[[sBoxCast1:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK-DAG: %[[ten1:.*]] = fir.convert %c10{{.*}} : (i32) -> i64
-    ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast1]], %[[ten1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}})
-    ! CHECK-NOT: AllocatableSetBounds
-    ! CHECK: %[[sBoxCast2:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[sBoxCast2]]
-  
-    ! CHECK-DAG: %[[aBoxCast1:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK-DAG: %[[ten2:.*]] = fir.convert %c10{{.*}} : (i32) -> i64
-    ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast1]], %[[ten2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}})
-    ! CHECK: %[[aBoxCast2:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableSetBounds(%[[aBoxCast2]]
-    ! CHECK: %[[aBoxCast3:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableAllocate(%[[aBoxCast3]]
-  
-    deallocate(scalar, array)
-    ! CHECK: %[[sBoxCast3:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[sBoxCast3]]
-    ! CHECK: %[[aBoxCast4:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableDeallocate(%[[aBoxCast4]]
-  
-    ! only testing that the correct length is set in the descriptor.
-    allocate(character(n):: scalar, array(40))
-    ! CHECK: %[[n:.*]] = fir.load %arg0 : !fir.ref<i32>
-    ! CHECK-DAG: %[[ncast1:.*]] = fir.convert %[[n]] : (i32) -> i64
-    ! CHECK-DAG: %[[sBoxCast4:.*]] = fir.convert %[[sBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[sBoxCast4]], %[[ncast1]], %c1{{.*}}, %c0{{.*}}, %c0{{.*}})
-    ! CHECK-DAG: %[[ncast2:.*]] = fir.convert %[[n]] : (i32) -> i64
-    ! CHECK-DAG: %[[aBoxCast5:.*]] = fir.convert %[[aBoxAddr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<none>>
-    ! CHECK: fir.call @{{.*}}AllocatableInitCharacter(%[[aBoxCast5]], %[[ncast2]], %c1{{.*}}, %c1{{.*}}, %c0{{.*}})
-  end subroutine
-  
-  ! CHECK-LABEL: _QPchar_explicit_cst(
-  subroutine char_explicit_cst(n)
-    integer :: n
-    character(10), allocatable :: scalar, array(:)
-    ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,10>>> {{{.*}}uniq_name = "_QFchar_explicit_cstEscalar"}
-    ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,10>>
-    ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] : (!fir.heap<!fir.char<1,10>>) -> !fir.box<!fir.heap<!fir.char<1,10>>>
-    ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>
-  
-    ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>> {{{.*}}uniq_name = "_QFchar_explicit_cstEarray"}
-    ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,10>>>
-    ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
-    ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) : (!fir.heap<!fir.array<?x!fir.char<1,10>>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>
-    ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>
-    allocate(scalar, array(20))
-    ! CHECK-NOT: AllocatableInitCharacter
-    ! CHECK: AllocatableAllocate
-    ! CHECK-NOT: AllocatableInitCharacter
-    ! CHECK: AllocatableAllocate
-    deallocate(scalar, array)
-    ! CHECK: AllocatableDeallocate
-    ! CHECK: AllocatableDeallocate
-  end subroutine
-  
-  ! CHECK-LABEL: _QPchar_explicit_dyn(
-  subroutine char_explicit_dyn(n, l1, l2)
-    integer :: n, l1, l2
-    character(l1), allocatable :: scalar
-    ! CHECK-DAG: %[[l1:.*]] = fir.load %arg1 : !fir.ref<i32>
-    ! CHECK-DAG: %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEscalar"}
-    ! CHECK-DAG: %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,?>>
-    ! CHECK-DAG: %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %[[l1]] : (!fir.heap<!fir.char<1,?>>, i32) -> !fir.box<!fir.heap<!fir.char<1,?>>>
-    ! CHECK-DAG: fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
-  
-    character(l2), allocatable :: array(:)
-    ! CHECK-DAG: %[[l2:.*]] = fir.load %arg2 : !fir.ref<i32>
-    ! CHECK-DAG: %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEarray"}
-    ! CHECK-DAG: %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,?>>>
-    ! CHECK-DAG: %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
-    ! CHECK-DAG: %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %[[l2]] : (!fir.heap<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, i32) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>
-    ! CHECK-DAG: fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
-    allocate(scalar, array(20))
-    ! CHECK-NOT: AllocatableInitCharacter
-    ! CHECK: AllocatableAllocate
-    ! CHECK-NOT: AllocatableInitCharacter
-    ! CHECK: AllocatableAllocate
-    deallocate(scalar, array)
-    ! CHECK: AllocatableDeallocate
-    ! CHECK: AllocatableDeallocate
-  end subroutine
+  ! CHECK:  %[[sBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEscalar"}
+  ! CHECK:  %[[raw_l1:.*]] = fir.load %arg1 : !fir.ref<i32>
+  ! CHECK:  %[[c0_i32:.*]] = arith.constant 0 : i32
+  ! CHECK:  %[[cmp1:.*]] = arith.cmpi sgt, %[[raw_l1]], %[[c0_i32]] : i32
+  ! CHECK:  %[[l1:.*]] = arith.select %[[cmp1]], %[[raw_l1]], %[[c0_i32]] : i32
+  ! CHECK:  %[[sNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.char<1,?>>
+  ! CHECK:  %[[sInitBox:.*]] = fir.embox %[[sNullAddr]] typeparams %[[l1]] : (!fir.heap<!fir.char<1,?>>, i32) -> !fir.box<!fir.heap<!fir.char<1,?>>>
+  ! CHECK:  fir.store %[[sInitBox]] to %[[sBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
+
+  character(l2), allocatable :: zarray(:)
+  ! CHECK:  %[[aBoxAddr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFchar_explicit_dynEzarray"}
+  ! CHECK:  %[[raw_l2:.*]] = fir.load %arg2 : !fir.ref<i32>
+  ! CHECK:  %[[c0_i32_2:.*]] = arith.constant 0 : i32
+  ! CHECK:  %[[cmp2:.*]] = arith.cmpi sgt, %[[raw_l2]], %[[c0_i32_2]] : i32
+  ! CHECK:  %[[l2:.*]] = arith.select %[[cmp2]], %[[raw_l2]], %[[c0_i32_2]] : i32
+  ! CHECK:  %[[aNullAddr:.*]] = fir.zero_bits !fir.heap<!fir.array<?x!fir.char<1,?>>>
+  ! CHECK:  %[[aNullShape:.*]] = fir.shape %c0{{.*}} : (index) -> !fir.shape<1>
+  ! CHECK:  %[[aInitBox:.*]] = fir.embox %[[aNullAddr]](%[[aNullShape]]) typeparams %[[l2]] : (!fir.heap<!fir.array<?x!fir.char<1,?>>>, !fir.shape<1>, i32) -> !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>
+  ! CHECK:  fir.store %[[aInitBox]] to %[[aBoxAddr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
+  allocate(scalar, zarray(20))
+  deallocate(scalar, zarray)

flang/test/Lower/allocatables.f90

subroutine char_explicit_cst(n)
   ! CHECK: %[[cAddrcast:.*]] = fir.convert %[[cAddr]] : (!fir.heap<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
   ! CHECK: fir.emboxchar %[[cAddrcast]], %[[cLen]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
 end subroutine
 
 ! CHECK-LABEL: _QPchar_explicit_dyn(
 subroutine char_explicit_dyn(l1, l2)
   integer :: l1, l2
   character(l1), allocatable :: c
-  ! CHECK-DAG: %[[cLen:.*]] = fir.load %arg0 : !fir.ref<i32>
-  ! CHECK-DAG: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,?>> {{{.*}}uniq_name = "_QFchar_explicit_dynEc.addr"}
+  ! CHECK: %[[l1:.*]] = fir.load %arg0 : !fir.ref<i32>
+  ! CHECK: %[[c0_i32:.*]] = arith.constant 0 : i32
+  ! CHECK: %[[cmp:.*]] = arith.cmpi sgt, %[[l1]], %[[c0_i32]] : i32
+  ! CHECK: %[[cLen:.*]] = arith.select %[[cmp]], %[[l1]], %[[c0_i32]] : i32
+  ! CHECK: %[[cAddrVar:.*]] = fir.alloca !fir.heap<!fir.char<1,?>> {{{.*}}uniq_name = "_QFchar_explicit_dynEc.addr"}
   ! CHECK-NOT: "_QFchar_explicit_dynEc.len"
   allocate(c)
   ! CHECK: %[[cLenCast1:.*]] = fir.convert %[[cLen]] : (i32) -> index
   ! CHECK: fir.allocmem !fir.char<1,?>(%[[cLenCast1]] : index) {{{.*}}uniq_name = "_QFchar_explicit_dynEc.alloc"}
   deallocate(c)
   ! CHECK: fir.freemem %{{.*}}
   allocate(character(l2):: c)
   ! CHECK: %[[cLenCast2:.*]] = fir.convert %[[cLen]] : (i32) -> index

flang/test/Lower/dummy-procedure-character.f90

+! Test lowering of character function dummy procedure. The length must be
+! passed along the function address.
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! -----------------------------------------------------------------------------
+!     Test passing a character function as dummy procedure
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPcst_len
+subroutine cst_len()
+    interface
+      character(7) function bar1()
+      end function
+    end interface
+    call foo1(bar1)
+  ! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPbar1) : (!fir.ref<!fir.char<1,7>>, index) -> !fir.boxchar<1>
+  ! CHECK:  %[[VAL_1:.*]] = arith.constant 7 : i64
+  ! CHECK:  %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,7>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  fir.call @_QPfoo1(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPcst_len_array
+  subroutine cst_len_array()
+    interface
+      function bar1_array()
+        character(7) :: bar1_array(10)
+      end function
+    end interface
+  ! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPbar1_array) : () -> !fir.array<10x!fir.char<1,7>>
+  ! CHECK:  %[[VAL_1:.*]] = arith.constant 7 : i64
+  ! CHECK:  %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : (() -> !fir.array<10x!fir.char<1,7>>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  fir.call @_QPfoo1b(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+    call foo1b(bar1_array)
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPcst_len_2
+  subroutine cst_len_2()
+    character(7) :: bar2
+    external :: bar2
+  ! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPbar2) : (!fir.ref<!fir.char<1,7>>, index) -> !fir.boxchar<1>
+  ! CHECK:  %[[VAL_1:.*]] = arith.constant 7 : i64
+  ! CHECK:  %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,7>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  fir.call @_QPfoo2(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+    call foo2(bar2)
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPdyn_len(
+  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32>{{.*}}) {
+  subroutine dyn_len(n)
+    integer :: n
+    character(n) :: bar3
+    external :: bar3
+  ! CHECK:  %[[VAL_1:.*]] = fir.address_of(@_QPbar3) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<i32>
+  ! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (i32) -> i64
+  ! CHECK:  %[[VAL_4:.*]] = arith.constant 0 : i64
+  ! CHECK:  %[[VAL_5:.*]] = arith.cmpi sgt, %[[VAL_3]], %[[VAL_4]] : i64
+  ! CHECK:  %[[VAL_6:.*]] = arith.select %[[VAL_5]], %[[VAL_3]], %[[VAL_4]] : i64
+  ! CHECK:  %[[VAL_7:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_8:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_9:.*]] = fir.insert_value %[[VAL_8]], %[[VAL_7]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_10:.*]] = fir.insert_value %[[VAL_9]], %[[VAL_6]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  fir.call @_QPfoo3(%[[VAL_10]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+    call foo3(bar3)
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPcannot_compute_len_yet
+  subroutine cannot_compute_len_yet()
+    interface
+      function bar4(n)
+        integer :: n
+        character(n) :: bar4
+      end function
+    end interface
+  ! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPbar4) : (!fir.ref<!fir.char<1,?>>, index, !fir.ref<i32>) -> !fir.boxchar<1>
+  ! CHECK:  %[[VAL_1:.*]] = arith.constant -1 : index
+  ! CHECK:  %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,?>>, index, !fir.ref<i32>) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_1]] : (index) -> i64
+  ! CHECK:  %[[VAL_4:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  fir.call @_QPfoo4(%[[VAL_6]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+    call foo4(bar4)
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPcannot_compute_len_yet_2
+  subroutine cannot_compute_len_yet_2()
+    character(*) :: bar5
+    external :: bar5
+  ! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPbar5) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK:  %[[VAL_1:.*]] = arith.constant -1 : index
+  ! CHECK:  %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_1]] : (index) -> i64
+  ! CHECK:  %[[VAL_4:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  fir.call @_QPfoo5(%[[VAL_6]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+    call foo5(bar5)
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPforward_incoming_length
+  ! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+  subroutine forward_incoming_length(bar6)
+    character(*) :: bar6
+    external :: bar6
+  ! CHECK:  %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[WAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+  ! CHECK:  %[[VAL_2:.*]] = fir.extract_value %[[VAL_0]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
+  ! CHECK:  %[[WAL_1:.*]] = fir.emboxproc %[[WAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[WAL_1]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  fir.call @_QPfoo6(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+    call foo6(bar6)
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPoverride_incoming_length
+  ! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+  subroutine override_incoming_length(bar7)
+    character(7) :: bar7
+    external :: bar7
+  ! CHECK:  %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[WAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+  ! CHECK:  %[[VAL_2:.*]] = arith.constant 7 : i64
+  ! CHECK:  %[[WAL_1:.*]] = fir.emboxproc %[[WAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[WAL_1]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+  ! CHECK:  fir.call @_QPfoo7(%[[VAL_5]]) : (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+    call foo7(bar7)
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !     Test calling character dummy function
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QPcall_assumed_length
+  ! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+  subroutine call_assumed_length(bar8)
+    character(*) :: bar8
+    external :: bar8
+  ! CHECK:  %[[VAL_3:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[WAL_2:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+  ! CHECK:  %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
+  ! CHECK:  %[[VAL_6:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_4]] : i64) {bindc_name = ".result"}
+  ! CHECK:  %[[VAL_7:.*]] = fir.convert %[[WAL_2]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index, !fir.ref<i32>) -> !fir.boxchar<1>)
+  ! CHECK:  %[[VAL_8:.*]] = fir.convert %[[VAL_4]] : (i64) -> index
+  ! CHECK:  fir.call %[[VAL_7]](%[[VAL_6]], %[[VAL_8]], %{{.*}}) : (!fir.ref<!fir.char<1,?>>, index, !fir.ref<i32>) -> !fir.boxchar<1>
+    call test(bar8(42))
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPcall_explicit_length
+  ! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+  subroutine call_explicit_length(bar9)
+    character(7) :: bar9
+    external :: bar9
+  ! CHECK:  %[[VAL_1:.*]] = fir.alloca !fir.char<1,7> {bindc_name = ".result"}
+  ! CHECK:  %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[WAL_1:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+  ! CHECK:  %[[VAL_5:.*]] = arith.constant 7 : i64
+  ! CHECK:  %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
+  ! CHECK:  %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref<!fir.char<1,7>>, index, !fir.ref<i32>) -> !fir.boxchar<1>)
+  ! CHECK:  fir.call %[[VAL_8]](%[[VAL_1]], %[[VAL_6]], %{{.*}}) : (!fir.ref<!fir.char<1,7>>, index, !fir.ref<i32>) -> !fir.boxchar<1>
+    call test(bar9(42))
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPcall_explicit_length_with_iface
+  ! CHECK-SAME: %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+  subroutine call_explicit_length_with_iface(bar10)
+    interface
+      function bar10(n)
+        integer(8) :: n
+        character(n) :: bar10
+      end function
+    end interface
+  ! CHECK:  %[[VAL_1:.*]] = fir.alloca i64
+  ! CHECK:  %[[VAL_2:.*]] = arith.constant 42 : i64
+  ! CHECK:  fir.store %[[VAL_2]] to %[[VAL_1]] : !fir.ref<i64>
+  ! CHECK:  %[[VAL_3:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[WAL_1:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+  ! CHECK:  %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref<i64>
+  ! CHECK:  %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (i64) -> index
+  ! CHECK:  %[[VAL_6:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
+  ! CHECK:  %[[VAL_7:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_5]] : index) {bindc_name = ".result"}
+  ! CHECK:  %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index, !fir.ref<i64>) -> !fir.boxchar<1>)
+  ! CHECK:  fir.call %[[VAL_8]](%[[VAL_7]], %[[VAL_5]], %[[VAL_1]]) : (!fir.ref<!fir.char<1,?>>, index, !fir.ref<i64>) -> !fir.boxchar<1>
+    call test(bar10(42_8))
+  end subroutine
+  
+  
+  ! CHECK-LABEL: func @_QPhost(
+  ! CHECK-SAME:  %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64>
+  subroutine host(f)
+    character*(*) :: f
+    external :: f
+    ! CHECK:  %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1:.*]], %{{.*}} : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+    ! CHECK:  fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+    ! CHECK: fir.call @_QFhostPintern(%[[VAL_1]])
+    call intern()
+  contains
+  ! CHECK-LABEL: func @_QFhostPintern(
+  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>> {fir.host_assoc})
+    subroutine intern()
+  ! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : i32
+  ! CHECK:  %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+  ! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+  ! CHECK:  %[[VAL_4:.*]] = fir.extract_value %[[VAL_3]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[WAL_1:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+  ! CHECK:  %[[VAL_5:.*]] = fir.extract_value %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
+  ! CHECK:  %[[VAL_7:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_5]] : i64) {bindc_name = ".result"}
+  ! CHECK:  %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>)
+  ! CHECK:  %[[VAL_9:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
+  ! CHECK:  fir.call %[[VAL_8]](%[[VAL_7]], %[[VAL_9]]) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+      call test(f())
+    end subroutine
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPhost2(
+  ! CHECK-SAME:  %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc})
+  subroutine host2(f)
+    ! Test that dummy length is overridden by local length even when used
+    ! in the internal procedure. 
+    character*(42) :: f
+    external :: f
+    ! CHECK:  %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1:.*]], %{{.*}} : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+    ! CHECK:  fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+    ! CHECK: fir.call @_QFhost2Pintern(%[[VAL_1]])
+    call intern()
+  contains
+  ! CHECK-LABEL: func @_QFhost2Pintern(
+  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>> {fir.host_assoc})
+    subroutine intern()
+      ! CHECK:  %[[VAL_1:.*]] = fir.alloca !fir.char<1,42> {bindc_name = ".result"}
+      ! CHECK:  %[[VAL_2:.*]] = arith.constant 0 : i32
+      ! CHECK:  %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_2]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+      ! CHECK:  %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+      ! CHECK:  %[[VAL_5:.*]] = fir.extract_value %[[VAL_4]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+      ! CHECK:  %[[WAL_1:.*]] = fir.box_addr %[[VAL_5]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+      ! CHECK:  %[[VAL_6:.*]] = arith.constant 42 : i64
+      ! CHECK:  %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> index
+      ! CHECK:  %[[VAL_9:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref<!fir.char<1,42>>, index) -> !fir.boxchar<1>)
+      ! CHECK:  fir.call %[[VAL_9]](%[[VAL_1]], %[[VAL_7]]) : (!fir.ref<!fir.char<1,42>>, index) -> !fir.boxchar<1>
+      call test(f())
+    end subroutine
+  end subroutine

flang/test/Lower/dummy-procedure.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Test dummy procedures
+
+! Test of dummy procedure call
+! CHECK-LABEL: func @_QPfoo(
+! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32
+real function foo(bar)
+real :: bar, x
+! CHECK: %[[x:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Ex"}
+x = 42.
+! CHECK: %[[funccast:.*]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> f32)
+! CHECK: fir.call %[[funccast]](%[[x]]) : (!fir.ref<f32>) -> f32
+foo = bar(x)
+end function
+
+! Test case where dummy procedure is only transiting.
+! CHECK-LABEL: func @_QPprefoo(
+! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}}) -> f32
+real function prefoo(bar)
+external :: bar
+! CHECK: fir.call @_QPfoo(%arg0) : (!fir.boxproc<() -> ()>) -> f32
+prefoo = foo(bar)
+end function
+
+! Function that will be passed as dummy argument
+! CHECK-LABEL: func @_QPfunc(
+! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}}) -> f32
+real function func(x)
+real :: x
+func = x + 0.5
+end function
+
+! Test passing functions as dummy procedure arguments
+! CHECK-LABEL: func @_QPtest_func
+real function test_func()
+real :: func, prefoo
+external :: func
+!CHECK: %[[f:.*]] = fir.address_of(@_QPfunc) : (!fir.ref<f32>) -> f32
+!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
+!CHECK: fir.call @_QPprefoo(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> f32
+test_func = prefoo(func)
+end function
+
+! Repeat test with dummy subroutine
+
+! CHECK-LABEL: func @_QPfoo_sub(
+! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
+subroutine foo_sub(bar_sub)
+! CHECK: %[[x:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Ex"}
+x = 42.
+! CHECK: %[[funccast:.*]] = fir.box_addr %arg0 : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> ())
+! CHECK: fir.call %[[funccast]](%[[x]]) : (!fir.ref<f32>)
+call bar_sub(x)
+end subroutine
+
+! Test case where dummy procedure is only transiting.
+! CHECK-LABEL: func @_QPprefoo_sub(
+! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
+subroutine prefoo_sub(bar_sub)
+external :: bar_sub
+! CHECK: fir.call @_QPfoo_sub(%arg0) : (!fir.boxproc<() -> ()>) -> ()
+call foo_sub(bar_sub)
+end subroutine
+
+! Subroutine that will be passed as dummy argument
+! CHECK-LABEL: func @_QPsub(
+! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}})
+subroutine sub(x)
+real :: x
+print *, x
+end subroutine
+
+! Test passing functions as dummy procedure arguments
+! CHECK-LABEL: func @_QPtest_sub
+subroutine test_sub()
+external :: sub
+!CHECK: %[[f:.*]] = fir.address_of(@_QPsub) : (!fir.ref<f32>) -> ()
+!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> ()) -> !fir.boxproc<() -> ()>
+!CHECK: fir.call @_QPprefoo_sub(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
+call prefoo_sub(sub)
+end subroutine
+
+! CHECK-LABEL: func @_QPpassing_not_defined_in_file()
+subroutine passing_not_defined_in_file()
+external proc_not_defined_in_file
+! CHECK: %[[addr:.*]] = fir.address_of(@_QPproc_not_defined_in_file) : () -> ()
+! CHECK: %[[ep:.*]] = fir.emboxproc %[[addr]]
+! CHECK: fir.call @_QPprefoo_sub(%[[ep]]) : (!fir.boxproc<() -> ()>) -> ()
+call prefoo_sub(proc_not_defined_in_file)
+end subroutine
+
+! Test passing unrestricted intrinsics
+
+! Intrinsic using runtime
+! CHECK-LABEL: func @_QPtest_acos
+subroutine test_acos(x)
+intrinsic :: acos
+!CHECK: %[[f:.*]] = fir.address_of(@fir.acos.f32.ref_f32) : (!fir.ref<f32>) -> f32
+!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
+!CHECK: fir.call @_QPfoo_acos(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
+call foo_acos(acos)
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_atan2
+subroutine test_atan2()
+intrinsic :: atan2
+! CHECK: %[[f:.*]] = fir.address_of(@fir.atan2.f32.ref_f32.ref_f32) : (!fir.ref<f32>, !fir.ref<f32>) -> f32
+! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<f32>, !fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
+! CHECK: fir.call @_QPfoo_atan2(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
+call foo_atan2(atan2)
+end subroutine
+
+! Intrinsic implemented inlined
+! CHECK-LABEL: func @_QPtest_aimag
+subroutine test_aimag()
+intrinsic :: aimag
+!CHECK: %[[f:.*]] = fir.address_of(@fir.aimag.f32.ref_z4) : (!fir.ref<!fir.complex<4>>) -> f32
+!CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<!fir.complex<4>>) -> f32) -> !fir.boxproc<() -> ()>
+!CHECK: fir.call @_QPfoo_aimag(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
+call foo_aimag(aimag)
+end subroutine
+
+! Character Intrinsic implemented inlined
+! CHECK-LABEL: func @_QPtest_len
+subroutine test_len()
+intrinsic :: len
+! CHECK: %[[f:.*]] = fir.address_of(@fir.len.i32.bc1) : (!fir.boxchar<1>) -> i32
+! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.boxchar<1>) -> i32) -> !fir.boxproc<() -> ()>
+!CHECK: fir.call @_QPfoo_len(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
+call foo_len(len)
+end subroutine
+
+! Intrinsic implemented inlined with specific name different from generic
+! CHECK-LABEL: func @_QPtest_iabs
+subroutine test_iabs()
+intrinsic :: iabs
+! CHECK: %[[f:.*]] = fir.address_of(@fir.abs.i32.ref_i32) : (!fir.ref<i32>) -> i32
+! CHECK: %[[fcast:.*]] = fir.emboxproc %[[f]] : ((!fir.ref<i32>) -> i32) -> !fir.boxproc<() -> ()>
+! CHECK: fir.call @_QPfoo_iabs(%[[fcast]]) : (!fir.boxproc<() -> ()>) -> ()
+call foo_iabs(iabs)
+end subroutine
+
+! TODO: exhaustive test of unrestricted intrinsic table 16.2 
+
+! TODO: improve dummy procedure types when interface is given.
+! CHECK: func @_QPtodo3(
+! CHECK-SAME: %{{.*}}: !fir.boxproc<() -> ()>{{.*}})
+! SHOULD-CHECK: func @_QPtodo3(%arg0: (!fir.ref<f32>) -> f32)
+subroutine todo3(dummy_proc)
+intrinsic :: acos
+procedure(acos) :: dummy_proc
+end subroutine
+
+! CHECK-LABEL: func private @fir.acos.f32.ref_f32(%arg0: !fir.ref<f32>) -> f32
+!CHECK: %[[load:.*]] = fir.load %arg0
+!CHECK: %[[res:.*]] = fir.call @__fs_acos_1(%[[load]]) : (f32) -> f32
+!CHECK: return %[[res]] : f32
+
+! CHECK-LABEL: func private @fir.atan2.f32.ref_f32.ref_f32(
+! CHECK-SAME: %[[x:.*]]: !fir.ref<f32>, %[[y:.*]]: !fir.ref<f32>) -> f32
+! CHECK-DAG: %[[xload:.*]] = fir.load %[[x]] : !fir.ref<f32>
+! CHECK-DAG: %[[yload:.*]] = fir.load %[[y]] : !fir.ref<f32>
+! CHECK: %[[atan2:.*]] = fir.call @__fs_atan2_1(%[[xload]], %[[yload]]) : (f32, f32) -> f32
+! CHECK: return %[[atan2]] : f32
+
+!CHECK-LABEL: func private @fir.aimag.f32.ref_z4(%arg0: !fir.ref<!fir.complex<4>>)
+!CHECK: %[[load:.*]] = fir.load %arg0
+!CHECK: %[[imag:.*]] = fir.extract_value %[[load]], [1 : index] : (!fir.complex<4>) -> f32
+!CHECK: return %[[imag]] : f32
+
+!CHECK-LABEL: func private @fir.len.i32.bc1(%arg0: !fir.boxchar<1>)
+!CHECK: %[[unboxed:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+!CHECK: %[[len:.*]] = fir.convert %[[unboxed]]#1 : (index) -> i32
+!CHECK: return %[[len]] : i32

flang/test/Lower/host-associated.f90

 ! Test internal procedure host association lowering.
-! RUN: bbc %s -o - -emit-fir | FileCheck %s
+! RUN: bbc %s -o - | FileCheck %s
 
 ! -----------------------------------------------------------------------------
 !     Test non character intrinsic scalars
 ! -----------------------------------------------------------------------------
 
 !!! Test scalar (with implicit none)
 
 ! CHECK-LABEL: func @_QPtest1(
contains
   ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxchar<1>>> {fir.host_assoc}) {
   subroutine test6_inner
     ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
     ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.boxchar<1>>
     ! CHECK: fir.unboxchar %[[load]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
     c = "Hi there"
   end subroutine test6_inner
 end subroutine test6
+
+! -----------------------------------------------------------------------------
+!     Test non allocatable and pointer arrays
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPtest3(
+! CHECK-SAME: %[[p:[^:]+]]: !fir.box<!fir.array<?xf32>>{{.*}}, %[[q:.*]]: !fir.box<!fir.array<?xf32>>{{.*}}, %[[i:.*]]: !fir.ref<i64>
+subroutine test3(p,q,i)
+  integer(8) :: i
+  real :: p(i:)
+  real :: q(:)
+  ! CHECK: %[[iload:.*]] = fir.load %[[i]] : !fir.ref<i64>
+  ! CHECK: %[[icast:.*]] = fir.convert %[[iload]] : (i64) -> index
+  ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>
+  ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
+  ! CHECK: %[[pshift:.*]] = fir.shift %[[icast]] : (index) -> !fir.shift<1>
+  ! CHECK: %[[pbox:.*]] = fir.rebox %[[p]](%[[pshift]]) : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
+  ! CHECK: fir.store %[[pbox]] to %[[ptup]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
+  ! CHECK: %[[qtup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
+  ! CHECK: %[[qbox:.*]] = fir.rebox %[[q]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xf32>>
+  ! CHECK: fir.store %[[qbox]] to %[[qtup]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
+
+  i = i + 1
+  q = -42.0
+
+  ! CHECK: fir.call @_QFtest3Ptest3_inner(%[[tup]]) : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>) -> ()
+  call test3_inner
+
+  if (p(2) .ne. -42.0) then
+     print *, "failed"
+  end if
+  
+contains
+  ! CHECK-LABEL: func @_QFtest3Ptest3_inner(
+  ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>> {fir.host_assoc}) {
+  subroutine test3_inner
+    ! CHECK: %[[pcoor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
+    ! CHECK: %[[p:.*]] = fir.load %[[pcoor]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
+    ! CHECK: %[[pbounds:.]]:3 = fir.box_dims %[[p]], %c0{{.*}} : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index)
+    ! CHECK: %[[qcoor:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
+    ! CHECK: %[[q:.*]] = fir.load %[[qcoor]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
+    ! CHECK: %[[qbounds:.]]:3 = fir.box_dims %[[q]], %c0{{.*}} : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index)
+
+
+    ! CHECK: %[[qlb:.*]] = fir.convert %[[qbounds]]#0 : (index) -> i64
+    ! CHECK: %[[qoffset:.*]] = arith.subi %c1{{.*}}, %[[qlb]] : i64
+    ! CHECK: %[[qelt:.*]] = fir.coordinate_of %[[q]], %[[qoffset]] : (!fir.box<!fir.array<?xf32>>, i64) -> !fir.ref<f32>
+    ! CHECK: %[[qload:.*]] = fir.load %[[qelt]] : !fir.ref<f32>
+    ! CHECK: %[[plb:.*]] = fir.convert %[[pbounds]]#0 : (index) -> i64
+    ! CHECK: %[[poffset:.*]] = arith.subi %c2{{.*}}, %[[plb]] : i64
+    ! CHECK: %[[pelt:.*]] = fir.coordinate_of %[[p]], %[[poffset]] : (!fir.box<!fir.array<?xf32>>, i64) -> !fir.ref<f32>
+    ! CHECK: fir.store %[[qload]] to %[[pelt]] : !fir.ref<f32>
+    p(2) = q(1)
+  end subroutine test3_inner
+end subroutine test3
+
+! CHECK-LABEL: func @_QPtest3a(
+! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.array<10xf32>>{{.*}}) {
+subroutine test3a(p)
+  real :: p(10)
+  real :: q(10)
+  ! CHECK: %[[q:.*]] = fir.alloca !fir.array<10xf32> {bindc_name = "q", uniq_name = "_QFtest3aEq"}
+  ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>
+  ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
+  ! CHECK: %[[shape:.*]] = fir.shape %c10{{.*}} : (index) -> !fir.shape<1>
+  ! CHECK: %[[pbox:.*]] = fir.embox %[[p]](%[[shape]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
+  ! CHECK: fir.store %[[pbox]] to %[[ptup]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
+  ! CHECK: %[[qtup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
+  ! CHECK: %[[qbox:.*]] = fir.embox %[[q]](%[[shape]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
+  ! CHECK: fir.store %[[qbox]] to %[[qtup]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
+
+  q = -42.0
+  ! CHECK: fir.call @_QFtest3aPtest3a_inner(%[[tup]]) : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>) -> ()
+  call test3a_inner
+
+  if (p(1) .ne. -42.0) then
+     print *, "failed"
+  end if
+  
+contains
+  ! CHECK: func @_QFtest3aPtest3a_inner(
+  ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>> {fir.host_assoc}) {
+  subroutine test3a_inner
+    ! CHECK: %[[pcoor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
+    ! CHECK: %[[p:.*]] = fir.load %[[pcoor]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
+    ! CHECK: %[[paddr:.*]] = fir.box_addr %[[p]] : (!fir.box<!fir.array<10xf32>>) -> !fir.ref<!fir.array<10xf32>>
+    ! CHECK: %[[qcoor:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.box<!fir.array<10xf32>>, !fir.box<!fir.array<10xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<10xf32>>>
+    ! CHECK: %[[q:.*]] = fir.load %[[qcoor]] : !fir.ref<!fir.box<!fir.array<10xf32>>>
+    ! CHECK: %[[qaddr:.*]] = fir.box_addr %[[q]] : (!fir.box<!fir.array<10xf32>>) -> !fir.ref<!fir.array<10xf32>>
+
+    ! CHECK: %[[qelt:.*]] = fir.coordinate_of %[[qaddr]], %c0{{.*}} : (!fir.ref<!fir.array<10xf32>>, i64) -> !fir.ref<f32>
+    ! CHECK: %[[qload:.*]] = fir.load %[[qelt]] : !fir.ref<f32>
+    ! CHECK: %[[pelt:.*]] = fir.coordinate_of %[[paddr]], %c0{{.*}} : (!fir.ref<!fir.array<10xf32>>, i64) -> !fir.ref<f32>
+    ! CHECK: fir.store %[[qload]] to %[[pelt]] : !fir.ref<f32>
+    p(1) = q(1)
+  end subroutine test3a_inner
+end subroutine test3a
+
+! -----------------------------------------------------------------------------
+!     Test allocatable and pointer scalars
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPtest4() {
+subroutine test4
+  real, pointer :: p
+  real, allocatable, target :: ally
+  ! CHECK: %[[ally:.*]] = fir.alloca !fir.box<!fir.heap<f32>> {bindc_name = "ally", fir.target, uniq_name = "_QFtest4Eally"}
+  ! CHECK: %[[p:.*]] = fir.alloca !fir.box<!fir.ptr<f32>> {bindc_name = "p", uniq_name = "_QFtest4Ep"}
+  ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>
+  ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
+  ! CHECK: fir.store %[[p]] to %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
+  ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
+  ! CHECK: fir.store %[[ally]] to %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
+  ! CHECK: fir.call @_QFtest4Ptest4_inner(%[[tup]]) : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>) -> ()
+
+  allocate(ally)
+  ally = -42.0
+  call test4_inner
+
+  if (p .ne. -42.0) then
+     print *, "failed"
+  end if
+  
+contains
+  ! CHECK-LABEL: func @_QFtest4Ptest4_inner(
+  ! CHECK-SAME:%[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>> {fir.host_assoc}) {
+  subroutine test4_inner
+    ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
+    ! CHECK: %[[p:.*]] = fir.load %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<f32>>>>
+    ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
+    ! CHECK: %[[a:.*]] = fir.load %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<f32>>>>
+    ! CHECK: %[[abox:.*]] = fir.load %[[a]] : !fir.ref<!fir.box<!fir.heap<f32>>>
+    ! CHECK: %[[addr:.*]] = fir.box_addr %[[abox]] : (!fir.box<!fir.heap<f32>>) -> !fir.heap<f32>
+    ! CHECK: %[[ptr:.*]] = fir.embox %[[addr]] : (!fir.heap<f32>) -> !fir.box<!fir.ptr<f32>>
+    ! CHECK: fir.store %[[ptr]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+    p => ally
+  end subroutine test4_inner
+end subroutine test4
+
+! -----------------------------------------------------------------------------
+!     Test allocatable and pointer arrays
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPtest5() {
+subroutine test5
+  real, pointer :: p(:)
+  real, allocatable, target :: ally(:)
+
+  ! CHECK: %[[ally:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xf32>>> {bindc_name = "ally", fir.target
+  ! CHECK: %[[p:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?xf32>>> {bindc_name = "p"
+  ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
+  ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
+  ! CHECK: fir.store %[[p]] to %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
+  ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
+  ! CHECK: fir.store %[[ally]] to %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
+  ! CHECK: fir.call @_QFtest5Ptest5_inner(%[[tup]]) : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>) -> ()
+
+  allocate(ally(10))
+  ally = -42.0
+  call test5_inner
+
+  if (p(1) .ne. -42.0) then
+     print *, "failed"
+  end if
+  
+contains
+  ! CHECK-LABEL: func @_QFtest5Ptest5_inner(
+  ! CHECK-SAME:%[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>> {fir.host_assoc}) {
+  subroutine test5_inner
+    ! CHECK: %[[ptup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
+    ! CHECK: %[[p:.*]] = fir.load %[[ptup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>>
+    ! CHECK: %[[atup:.*]] = fir.coordinate_of %[[tup]], %c1{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
+    ! CHECK: %[[a:.*]] = fir.load %[[atup]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>>
+    ! CHECK: %[[abox:.*]] = fir.load %[[a]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
+    ! CHECK-DAG: %[[adims:.*]]:3 = fir.box_dims %[[abox]], %c0{{.*}} : (!fir.box<!fir.heap<!fir.array<?xf32>>>, index) -> (index, index, index)
+    ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[abox]] : (!fir.box<!fir.heap<!fir.array<?xf32>>>) -> !fir.heap<!fir.array<?xf32>>
+    ! CHECK-DAG: %[[ashape:.*]] = fir.shape_shift %[[adims]]#0, %[[adims]]#1 : (index, index) -> !fir.shapeshift<1>
+
+    ! CHECK: %[[ptr:.*]] = fir.embox %[[addr]](%[[ashape]]) : (!fir.heap<!fir.array<?xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+    ! CHECK: fir.store %[[ptr]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    p => ally
+  end subroutine test5_inner
+end subroutine test5
+
+
+! -----------------------------------------------------------------------------
+!     Test elemental internal procedure
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPtest7(
+! CHECK-SAME: %[[j:.*]]: !fir.ref<i32>{{.*}}, %[[k:.*]]: !fir.box<!fir.array<?xi32>>
+subroutine test7(j, k)
+  implicit none
+  integer :: j
+  integer :: k(:)
+  ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<i32>>
+  ! CHECK: %[[jtup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK: fir.store %[[j]] to %[[jtup]] : !fir.llvm_ptr<!fir.ref<i32>>
+
+  ! CHECK: %[[kelem:.*]] = fir.array_coor %[[k]] %{{.*}} : (!fir.box<!fir.array<?xi32>>, index) -> !fir.ref<i32>
+  ! CHECK: fir.call @_QFtest7Ptest7_inner(%[[kelem]], %[[tup]]) : (!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> i32
+  k = test7_inner(k)
+contains
+
+! CHECK-LABEL: func @_QFtest7Ptest7_inner(
+! CHECK-SAME: %[[i:.*]]: !fir.ref<i32>{{.*}}, %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) -> i32 {
+elemental integer function test7_inner(i)
+  implicit none
+  integer, intent(in) :: i
+  ! CHECK: %[[jtup:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK: %[[jptr:.*]] = fir.load %[[jtup]] : !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK-DAG: %[[iload:.*]] = fir.load %[[i]] : !fir.ref<i32>
+  ! CHECK-DAG: %[[jload:.*]] = fir.load %[[jptr]] : !fir.ref<i32>
+  ! CHECK: addi %[[iload]], %[[jload]] : i32
+  test7_inner = i + j
+end function
+end subroutine
+
+subroutine issue990()
+  ! Test that host symbols used in statement functions inside an internal
+  ! procedure are correctly captured from the host.
+  implicit none
+  integer :: captured
+  call bar()
+contains
+! CHECK-LABEL: func @_QFissue990Pbar(
+! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) {
+subroutine bar()
+  integer :: stmt_func, i
+  stmt_func(i) = i + captured
+  ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK: %[[addr:.*]] = fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK: %[[value:.*]] = fir.load %[[addr]] : !fir.ref<i32>
+  ! CHECK: arith.addi %{{.*}}, %[[value]] : i32
+  print *, stmt_func(10)
+end subroutine
+end subroutine
+
+subroutine issue990b()
+  ! Test when an internal procedure uses a statement function from its host
+  ! which uses host variables that are otherwise not used by the internal
+  ! procedure.
+  implicit none
+  integer :: captured, captured_stmt_func, i
+  captured_stmt_func(i) = i + captured
+  call bar()
+contains
+! CHECK-LABEL: func @_QFissue990bPbar(
+! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) {
+subroutine bar()
+  ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK: %[[addr:.*]] = fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK: %[[value:.*]] = fir.load %[[addr]] : !fir.ref<i32>
+  ! CHECK: arith.addi %{{.*}}, %[[value]] : i32
+  print *, captured_stmt_func(10)
+end subroutine
+end subroutine
+
+! Test capture of dummy procedure functions.
+subroutine test8(dummy_proc)
+ implicit none
+ interface
+   real function dummy_proc(x)
+    real :: x
+   end function
+ end interface
+ call bar()
+contains
+! CHECK-LABEL: func @_QFtest8Pbar(
+! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxproc<() -> ()>>> {fir.host_assoc}) {
+subroutine bar()
+  ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxproc<() -> ()>>>, i32) -> !fir.ref<!fir.boxproc<() -> ()>>
+  ! CHECK: %[[dummyProc:.*]] = fir.load %[[tupAddr]] : !fir.ref<!fir.boxproc<() -> ()>>
+  ! CHECK: %[[dummyProcCast:.*]] = fir.box_addr %[[dummyProc]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref<f32>) -> f32)
+  ! CHECK: fir.call %[[dummyProcCast]](%{{.*}}) : (!fir.ref<f32>) -> f32
+ print *, dummy_proc(42.)
+end subroutine
+end subroutine
+
+! Test capture of dummy subroutines.
+subroutine test9(dummy_proc)
+ implicit none
+ interface
+   subroutine dummy_proc()
+   end subroutine
+ end interface
+ call bar()
+contains
+! CHECK-LABEL: func @_QFtest9Pbar(
+! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxproc<() -> ()>>> {fir.host_assoc}) {
+subroutine bar()
+  ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxproc<() -> ()>>>, i32) -> !fir.ref<!fir.boxproc<() -> ()>>
+  ! CHECK: %[[dummyProc:.*]] = fir.load %[[tupAddr]] : !fir.ref<!fir.boxproc<() -> ()>>
+  ! CHECK: %[[pa:.*]] = fir.box_addr %[[dummyProc]]
+  ! CHECK: fir.call %[[pa]]() : () -> ()
+  call dummy_proc()
+end subroutine
+end subroutine
+
+! Test capture of namelist
+! CHECK-LABEL: func @_QPtest10(
+! CHECK-SAME: %[[i:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>{{.*}}) {
+subroutine test10(i)
+ implicit none
+ integer, pointer :: i(:)
+ namelist /a_namelist/ i
+ ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup:.*]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
+ ! CHECK: fir.store %[[i]] to %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
+ ! CHECK: fir.call @_QFtest10Pbar(%[[tup]]) : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>) -> ()
+ call bar()
+contains
+! CHECK-LABEL: func @_QFtest10Pbar(
+! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>> {fir.host_assoc}) {
+subroutine bar()
+  ! CHECK: %[[tupAddr:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
+  ! CHECK: fir.load %[[tupAddr]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>>
+  read (88, NML = a_namelist) 
+end subroutine
+end subroutine
+
+! Test passing an internal procedure as a dummy argument.
+
+! CHECK-LABEL: func @_QPtest_proc_dummy() {
+! CHECK:         %[[VAL_4:.*]] = fir.alloca i32 {bindc_name = "i", uniq_name = "_QFtest_proc_dummyEi"}
+! CHECK:         %[[VAL_5:.*]] = fir.alloca tuple<!fir.ref<i32>>
+! CHECK:         %[[VAL_7:.*]] = fir.address_of(@_QFtest_proc_dummyPtest_proc_dummy_a) : (!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> ()
+! CHECK:         %[[VAL_8:.*]] = fir.emboxproc %[[VAL_7]], %[[VAL_5]] : ((!fir.ref<i32>, !fir.ref<tuple<!fir.ref<i32>>>) -> (), !fir.ref<tuple<!fir.ref<i32>>>) -> !fir.boxproc<() -> ()>
+! CHECK:         fir.call @_QPtest_proc_dummy_other(%[[VAL_8]]) : (!fir.boxproc<() -> ()>) -> ()
+
+! CHECK-LABEL: func @_QFtest_proc_dummyPtest_proc_dummy_a(
+! CHECK-SAME:          %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "j"},
+! CHECK-SAME:          %[[VAL_1:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) {
+! CHECK:         %[[VAL_2:.*]] = arith.constant 0 : i32
+! CHECK:         %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:         %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:         %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref<i32>
+! CHECK:         %[[VAL_6:.*]] = fir.load %[[VAL_0]] : !fir.ref<i32>
+! CHECK:         %[[VAL_7:.*]] = arith.addi %[[VAL_5]], %[[VAL_6]] : i32
+! CHECK:         fir.store %[[VAL_7]] to %[[VAL_4]] : !fir.ref<i32>
+! CHECK:         return
+! CHECK:       }
+
+! CHECK-LABEL: func @_QPtest_proc_dummy_other(
+! CHECK-SAME:           %[[VAL_0:.*]]: !fir.boxproc<() -> ()>) {
+! CHECK:         %[[VAL_1:.*]] = arith.constant 4 : i32
+! CHECK:         %[[VAL_2:.*]] = fir.alloca i32 {adapt.valuebyref}
+! CHECK:         fir.store %[[VAL_1]] to %[[VAL_2]] : !fir.ref<i32>
+! CHECK:         %[[VAL_3:.*]] = fir.box_addr %[[VAL_0]] : (!fir.boxproc<() -> ()>) -> ((!fir.ref<i32>) -> ())
+! CHECK:         fir.call %[[VAL_3]](%[[VAL_2]]) : (!fir.ref<i32>) -> ()
+! CHECK:         return
+! CHECK:       }
+
+subroutine test_proc_dummy
+  integer i
+  i = 1
+  call test_proc_dummy_other(test_proc_dummy_a)
+  print *, i
+contains
+  subroutine test_proc_dummy_a(j)
+    i = i + j
+  end subroutine test_proc_dummy_a
+end subroutine test_proc_dummy
+
+subroutine test_proc_dummy_other(proc)
+  call proc(4)
+end subroutine test_proc_dummy_other
+
+! CHECK-LABEL: func @_QPtest_proc_dummy_char() {
+! CHECK-DAG:         %[[VAL_0:.*]] = arith.constant 10 : index
+! CHECK-DAG:         %[[VAL_1:.*]] = arith.constant 0 : i32
+! CHECK-DAG:         %[[VAL_2:.*]] = arith.constant 9 : index
+! CHECK-DAG:         %[[VAL_3:.*]] = arith.constant false
+! CHECK-DAG:         %[[VAL_4:.*]] = arith.constant 1 : index
+! CHECK-DAG:         %[[VAL_5:.*]] = arith.constant 32 : i8
+! CHECK-DAG:         %[[VAL_6:.*]] = arith.constant -1 : i32
+! CHECK-DAG:         %[[VAL_8:.*]] = arith.constant 10 : i64
+! CHECK-DAG:         %[[VAL_9:.*]] = arith.constant 40 : index
+! CHECK-DAG:         %[[VAL_10:.*]] = arith.constant 0 : index
+! CHECK:         %[[VAL_11:.*]] = fir.alloca !fir.char<1,40> {bindc_name = ".result"}
+! CHECK:         %[[VAL_12:.*]] = fir.alloca !fir.char<1,10> {bindc_name = "message", uniq_name = "_QFtest_proc_dummy_charEmessage"}
+! CHECK:         %[[VAL_13:.*]] = fir.alloca tuple<!fir.boxchar<1>>
+! CHECK:         %[[VAL_14:.*]] = fir.coordinate_of %[[VAL_13]], %[[VAL_1]] : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
+! CHECK:         %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
+! CHECK:         %[[VAL_16:.*]] = fir.emboxchar %[[VAL_15]], %[[VAL_0]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+! CHECK:         fir.store %[[VAL_16]] to %[[VAL_14]] : !fir.ref<!fir.boxchar<1>>
+! CHECK:         %[[VAL_17:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,9>>
+! CHECK:         %[[VAL_18:.*]] = fir.convert %[[VAL_2]] : (index) -> i64
+! CHECK:         %[[VAL_19:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<i8>
+! CHECK:         %[[VAL_20:.*]] = fir.convert %[[VAL_17]] : (!fir.ref<!fir.char<1,9>>) -> !fir.ref<i8>
+! CHECK:         fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_19]], %[[VAL_20]], %[[VAL_18]], %[[VAL_3]]) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
+! CHECK:         %[[VAL_21:.*]] = fir.undefined !fir.char<1>
+! CHECK:         %[[VAL_22:.*]] = fir.insert_value %[[VAL_21]], %[[VAL_5]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
+! CHECK:         br ^bb1(%[[VAL_2]], %[[VAL_4]] : index, index)
+! CHECK:       ^bb1(%[[VAL_23:.*]]: index, %[[VAL_24:.*]]: index):
+! CHECK:         %[[VAL_25:.*]] = arith.cmpi sgt, %[[VAL_24]], %[[VAL_10]] : index
+! CHECK:         cond_br %[[VAL_25]], ^bb2, ^bb3
+! CHECK:       ^bb2:
+! CHECK:         %[[VAL_26:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.array<10x!fir.char<1>>>
+! CHECK:         %[[VAL_27:.*]] = fir.coordinate_of %[[VAL_26]], %[[VAL_23]] : (!fir.ref<!fir.array<10x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
+! CHECK:         fir.store %[[VAL_22]] to %[[VAL_27]] : !fir.ref<!fir.char<1>>
+! CHECK:         %[[VAL_28:.*]] = arith.addi %[[VAL_23]], %[[VAL_4]] : index
+! CHECK:         %[[VAL_29:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index
+! CHECK:         br ^bb1(%[[VAL_28]], %[[VAL_29]] : index, index)
+! CHECK:       ^bb3:
+! CHECK:         %[[VAL_30:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,
+! CHECK:         %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
+! CHECK:         %[[VAL_32:.*]] = fir.call @_FortranAioBeginExternalListOutput(%[[VAL_6]], %[[VAL_31]], %{{.*}}) : (i32, !fir.ref<i8>, i32) -> !fir.ref<i8>
+! CHECK:         %[[VAL_33:.*]] = fir.address_of(@_QFtest_proc_dummy_charPgen_message) : (!fir.ref<!fir.char<1,10>>, index, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxchar<1>
+! CHECK:         %[[VAL_34:.*]] = fir.emboxproc %[[VAL_33]], %[[VAL_13]] : ((!fir.ref<!fir.char<1,10>>, index, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxchar<1>, !fir.ref<tuple<!fir.boxchar<1>>>) -> !fir.boxproc<() -> ()>
+! CHECK:         %[[VAL_35:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:         %[[VAL_36:.*]] = fir.insert_value %[[VAL_35]], %[[VAL_34]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:         %[[VAL_37:.*]] = fir.insert_value %[[VAL_36]], %[[VAL_8]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:         %[[VAL_38:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
+! CHECK:         %[[VAL_39:.*]] = fir.call @_QPget_message(%[[VAL_11]], %[[VAL_9]], %[[VAL_37]]) : (!fir.ref<!fir.char<1,40>>, index, tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxchar<1>
+! CHECK:         %[[VAL_40:.*]] = fir.convert %[[VAL_11]] : (!fir.ref<!fir.char<1,40>>) -> !fir.ref<i8>
+! CHECK:         %[[VAL_41:.*]] = fir.convert %[[VAL_9]] : (index) -> i64
+! CHECK:         %[[VAL_42:.*]] = fir.call @_FortranAioOutputAscii(%[[VAL_32]], %[[VAL_40]], %[[VAL_41]]) : (!fir.ref<i8>, !fir.ref<i8>, i64) -> i1
+! CHECK:         fir.call @llvm.stackrestore(%[[VAL_38]]) : (!fir.ref<i8>) -> ()
+! CHECK:         %[[VAL_43:.*]] = fir.call @_FortranAioEndIoStatement(%[[VAL_32]]) : (!fir.ref<i8>) -> i32
+! CHECK:         return
+! CHECK:       }
+
+! CHECK-LABEL: func @_QFtest_proc_dummy_charPgen_message(
+! CHECK-SAME:                                            %[[VAL_0:.*]]: !fir.ref<!fir.char<1,10>>,
+! CHECK-SAME:                                            %[[VAL_1:.*]]: index,
+! CHECK-SAME:                                            %[[VAL_2:.*]]: !fir.ref<tuple<!fir.boxchar<1>>> {fir.host_assoc}) -> !fir.boxchar<1> {
+! CHECK-DAG:         %[[VAL_3:.*]] = arith.constant 0 : i32
+! CHECK-DAG:         %[[VAL_4:.*]] = arith.constant 10 : index
+! CHECK-DAG:         %[[VAL_5:.*]] = arith.constant false
+! CHECK-DAG:         %[[VAL_6:.*]] = arith.constant 1 : index
+! CHECK-DAG:         %[[VAL_7:.*]] = arith.constant 32 : i8
+! CHECK-DAG:         %[[VAL_8:.*]] = arith.constant 0 : index
+! CHECK:         %[[VAL_9:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
+! CHECK:         %[[VAL_10:.*]] = fir.load %[[VAL_9]] : !fir.ref<!fir.boxchar<1>>
+! CHECK:         %[[VAL_11:.*]]:2 = fir.unboxchar %[[VAL_10]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+! CHECK:         %[[VAL_12:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.char<1,10>>) -> !fir.ref<!fir.char<1,?>>
+! CHECK:         %[[VAL_13:.*]] = arith.cmpi slt, %[[VAL_4]], %[[VAL_11]]#1 : index
+! CHECK:         %[[VAL_14:.*]] = arith.select %[[VAL_13]], %[[VAL_4]], %[[VAL_11]]#1 : index
+! CHECK:         %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (index) -> i64
+! CHECK:         %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+! CHECK:         %[[VAL_17:.*]] = fir.convert %[[VAL_11]]#0 : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+! CHECK:         fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_16]], %[[VAL_17]], %[[VAL_15]], %[[VAL_5]]) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
+! CHECK:         %[[VAL_18:.*]] = fir.undefined !fir.char<1>
+! CHECK:         %[[VAL_19:.*]] = fir.insert_value %[[VAL_18]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
+! CHECK:         %[[VAL_20:.*]] = arith.subi %[[VAL_4]], %[[VAL_14]] : index
+! CHECK:         br ^bb1(%[[VAL_14]], %[[VAL_20]] : index, index)
+! CHECK:       ^bb1(%[[VAL_21:.*]]: index, %[[VAL_22:.*]]: index):
+! CHECK:         %[[VAL_23:.*]] = arith.cmpi sgt, %[[VAL_22]], %[[VAL_8]] : index
+! CHECK:         cond_br %[[VAL_23]], ^bb2, ^bb3
+! CHECK:       ^bb2:
+! CHECK:         %[[VAL_24:.*]] = fir.convert %[[VAL_12]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
+! CHECK:         %[[VAL_25:.*]] = fir.coordinate_of %[[VAL_24]], %[[VAL_21]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
+! CHECK:         fir.store %[[VAL_19]] to %[[VAL_25]] : !fir.ref<!fir.char<1>>
+! CHECK:         %[[VAL_26:.*]] = arith.addi %[[VAL_21]], %[[VAL_6]] : index
+! CHECK:         %[[VAL_27:.*]] = arith.subi %[[VAL_22]], %[[VAL_6]] : index
+! CHECK:         br ^bb1(%[[VAL_26]], %[[VAL_27]] : index, index)
+! CHECK:       ^bb3:
+! CHECK:         %[[VAL_28:.*]] = fir.emboxchar %[[VAL_12]], %[[VAL_4]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+! CHECK:         return %[[VAL_28]] : !fir.boxchar<1>
+! CHECK:       }
+
+! CHECK-LABEL: func @_QPget_message(
+! CHECK-SAME:                       %[[VAL_0:.*]]: !fir.ref<!fir.char<1,40>>,
+! CHECK-SAME:                       %[[VAL_1:.*]]: index,
+! CHECK-SAME:                       %[[VAL_2:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) -> !fir.boxchar<1> {
+! CHECK:         %[[VAL_3:.*]] = arith.constant 40 : index
+! CHECK:         %[[VAL_4:.*]] = arith.constant 12 : index
+! CHECK:         %[[VAL_5:.*]] = arith.constant false
+! CHECK:         %[[VAL_6:.*]] = arith.constant 1 : index
+! CHECK:         %[[VAL_7:.*]] = arith.constant 32 : i8
+! CHECK:         %[[VAL_8:.*]] = arith.constant 0 : index
+! CHECK:         %[[VAL_9:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.char<1,40>>) -> !fir.ref<!fir.char<1,?>>
+! CHECK:         %[[VAL_10:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref<!fir.char<1,12>>
+! CHECK:         %[[VAL_11:.*]] = fir.extract_value %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK:         %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:         %[[VAL_13:.*]] = fir.extract_value %[[VAL_2]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
+! CHECK:         %[[VAL_14:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
+! CHECK:         %[[VAL_15:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_13]] : i64) {bindc_name = ".result"}
+! CHECK:         %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>)
+! CHECK:         %[[VAL_17:.*]] = fir.convert %[[VAL_13]] : (i64) -> index
+! CHECK:         %[[VAL_18:.*]] = fir.call %[[VAL_16]](%[[VAL_15]], %[[VAL_17]]) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+! CHECK:         %[[VAL_19:.*]] = arith.addi %[[VAL_17]], %[[VAL_4]] : index
+! CHECK:         %[[VAL_20:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_19]] : index) {bindc_name = ".chrtmp"}
+! CHECK:         %[[VAL_21:.*]] = fir.convert %[[VAL_4]] : (index) -> i64
+! CHECK:         %[[VAL_22:.*]] = fir.convert %[[VAL_20]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+! CHECK:         %[[VAL_23:.*]] = fir.convert %[[VAL_10]] : (!fir.ref<!fir.char<1,12>>) -> !fir.ref<i8>
+! CHECK:         fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_22]], %[[VAL_23]], %[[VAL_21]], %[[VAL_5]]) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
+! CHECK:         br ^bb1(%[[VAL_4]], %[[VAL_17]] : index, index)
+! CHECK:       ^bb1(%[[VAL_24:.*]]: index, %[[VAL_25:.*]]: index):
+! CHECK:         %[[VAL_26:.*]] = arith.cmpi sgt, %[[VAL_25]], %[[VAL_8]] : index
+! CHECK:         cond_br %[[VAL_26]], ^bb2, ^bb3
+! CHECK:       ^bb2:
+! CHECK:         %[[VAL_27:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index
+! CHECK:         %[[VAL_28:.*]] = fir.convert %[[VAL_15]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
+! CHECK:         %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_27]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
+! CHECK:         %[[VAL_30:.*]] = fir.load %[[VAL_29]] : !fir.ref<!fir.char<1>>
+! CHECK:         %[[VAL_31:.*]] = fir.convert %[[VAL_20]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
+! CHECK:         %[[VAL_32:.*]] = fir.coordinate_of %[[VAL_31]], %[[VAL_24]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
+! CHECK:         fir.store %[[VAL_30]] to %[[VAL_32]] : !fir.ref<!fir.char<1>>
+! CHECK:         %[[VAL_33:.*]] = arith.addi %[[VAL_24]], %[[VAL_6]] : index
+! CHECK:         %[[VAL_34:.*]] = arith.subi %[[VAL_25]], %[[VAL_6]] : index
+! CHECK:         br ^bb1(%[[VAL_33]], %[[VAL_34]] : index, index)
+! CHECK:       ^bb3:
+! CHECK:         %[[VAL_35:.*]] = arith.cmpi slt, %[[VAL_3]], %[[VAL_19]] : index
+! CHECK:         %[[VAL_36:.*]] = arith.select %[[VAL_35]], %[[VAL_3]], %[[VAL_19]] : index
+! CHECK:         %[[VAL_37:.*]] = fir.convert %[[VAL_36]] : (index) -> i64
+! CHECK:         %[[VAL_38:.*]] = fir.convert %[[VAL_9]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<i8>
+! CHECK:         fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_38]], %[[VAL_22]], %[[VAL_37]], %[[VAL_5]]) : (!fir.ref<i8>, !fir.ref<i8>, i64, i1) -> ()
+! CHECK:         %[[VAL_39:.*]] = fir.undefined !fir.char<1>
+! CHECK:         %[[VAL_40:.*]] = fir.insert_value %[[VAL_39]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1>
+! CHECK:         %[[VAL_41:.*]] = arith.subi %[[VAL_3]], %[[VAL_36]] : index
+! CHECK:         br ^bb4(%[[VAL_36]], %[[VAL_41]] : index, index)
+! CHECK:       ^bb4(%[[VAL_42:.*]]: index, %[[VAL_43:.*]]: index):
+! CHECK:         %[[VAL_44:.*]] = arith.cmpi sgt, %[[VAL_43]], %[[VAL_8]] : index
+! CHECK:         cond_br %[[VAL_44]], ^bb5, ^bb6
+! CHECK:       ^bb5:
+! CHECK:         %[[VAL_45:.*]] = fir.convert %[[VAL_9]] : (!fir.ref<!fir.char<1,?>>) -> !fir.ref<!fir.array<?x!fir.char<1>>>
+! CHECK:         %[[VAL_46:.*]] = fir.coordinate_of %[[VAL_45]], %[[VAL_42]] : (!fir.ref<!fir.array<?x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
+! CHECK:         fir.store %[[VAL_40]] to %[[VAL_46]] : !fir.ref<!fir.char<1>>
+! CHECK:         %[[VAL_47:.*]] = arith.addi %[[VAL_42]], %[[VAL_6]] : index
+! CHECK:         %[[VAL_48:.*]] = arith.subi %[[VAL_43]], %[[VAL_6]] : index
+! CHECK:         br ^bb4(%[[VAL_47]], %[[VAL_48]] : index, index)
+! CHECK:       ^bb6:
+! CHECK:         fir.call @llvm.stackrestore(%[[VAL_14]]) : (!fir.ref<i8>) -> ()
+! CHECK:         %[[VAL_49:.*]] = fir.emboxchar %[[VAL_9]], %[[VAL_3]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+! CHECK:         return %[[VAL_49]] : !fir.boxchar<1>
+! CHECK:       }
+
+subroutine test_proc_dummy_char
+  character(40) get_message
+  external get_message
+  character(10) message
+  message = "Hi there!"
+  print *, get_message(gen_message)
+contains
+  function gen_message
+    character(10) :: gen_message
+    gen_message = message
+  end function gen_message
+end subroutine test_proc_dummy_char
+
+function get_message(a)
+  character(40) :: get_message
+  character(*) :: a
+  get_message = "message is: " // a() 
+end function get_message
+
+! CHECK-LABEL: func @_QPtest_11a() {
+! CHECK: %[[a:.*]] = fir.address_of(@_QPtest_11b) : () -> ()
+! CHECK: %[[b:.*]] = fir.emboxproc %[[a]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK: fir.call @_QPtest_11c(%[[b]], %{{.*}}) : (!fir.boxproc<() -> ()>, !fir.ref<i32>) -> ()
+! CHECK: func private @_QPtest_11c(!fir.boxproc<() -> ()>, !fir.ref<i32>)
+
+subroutine test_11a
+  external test_11b
+  call test_11c(test_11b, 3)
+end subroutine test_11a

flang/test/Lower/procedure-declarations.f90

 ! RUN: bbc -emit-fir %s -o - | FileCheck %s
 
 ! Test procedure declarations. Change appearance order of definition and usages
 ! (passing a procedure and calling it), with and without definitions.
 ! Check that the definition type prevail if available and that casts are inserted to
 ! accommodate for the signature mismatch in the different location due to implicit
 ! typing rules and Fortran loose interface compatibility rule history. 
 
 
 ! Note: all the cases where their is a definition are exactly the same,
 ! since definition should be processed first regardless.
 
 ! pass, call, define
+! CHECK-LABEL: func @_QPpass_foo() {
+subroutine pass_foo()
+  external :: foo
+  ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo)
+  ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
+  call bar(foo)
+end subroutine
 ! CHECK-LABEL: func @_QPcall_foo(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
 subroutine call_foo(i)
   integer :: i(10)
   ! %[[argconvert:*]] = fir.convert %arg0 :
   ! fir.call @_QPfoo(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
   call foo(i)
 end subroutine 
 ! CHECK-LABEL: func @_QPfoo(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
 subroutine foo(i)
   integer :: i(2, 5)
   call do_something(i)
 end subroutine
 
 ! call, pass, define
 ! CHECK-LABEL: func @_QPcall_foo2(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
 subroutine call_foo2(i)
   integer :: i(10)
   ! %[[argconvert:*]] = fir.convert %arg0 :
   ! fir.call @_QPfoo2(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
   call foo2(i)
 end subroutine 
+! CHECK-LABEL: func @_QPpass_foo2() {
+subroutine pass_foo2()
+  external :: foo2
+  ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo2)
+  ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
+  call bar(foo2)
+end subroutine
 ! CHECK-LABEL: func @_QPfoo2(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
 subroutine foo2(i)
   integer :: i(2, 5)
   call do_something(i)
 end subroutine
 
 ! call, define, pass
 ! CHECK-LABEL: func @_QPcall_foo3(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
 subroutine call_foo3(i)
   integer :: i(10)
   ! %[[argconvert:*]] = fir.convert %arg0 :
   ! fir.call @_QPfoo3(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
   call foo3(i)
 end subroutine 
 ! CHECK-LABEL: func @_QPfoo3(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
 subroutine foo3(i)
   integer :: i(2, 5)
   call do_something(i)
 end subroutine
+! CHECK-LABEL: func @_QPpass_foo3() {
+subroutine pass_foo3()
+  external :: foo3
+  ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo3)
+  ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
+  call bar(foo3)
+end subroutine
 
 ! define, call, pass
 ! CHECK-LABEL: func @_QPfoo4(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
 subroutine foo4(i)
   integer :: i(2, 5)
   call do_something(i)
 end subroutine
 ! CHECK-LABEL: func @_QPcall_foo4(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
 subroutine call_foo4(i)
   integer :: i(10)
   ! %[[argconvert:*]] = fir.convert %arg0 :
   ! fir.call @_QPfoo4(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
   call foo4(i)
 end subroutine 
+! CHECK-LABEL: func @_QPpass_foo4() {
+subroutine pass_foo4()
+  external :: foo4
+  ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo4)
+  ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
+  call bar(foo4)
+end subroutine
 
 ! define, pass, call
 ! CHECK-LABEL: func @_QPfoo5(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<2x5xi32>>{{.*}}) {
 subroutine foo5(i)
   integer :: i(2, 5)
   call do_something(i)
 end subroutine
+! CHECK-LABEL: func @_QPpass_foo5() {
+subroutine pass_foo5()
+  external :: foo5
+  ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo5)
+  ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<2x5xi32>>) -> ()) -> !fir.boxproc<() -> ()>
+  call bar(foo5)
+end subroutine
 ! CHECK-LABEL: func @_QPcall_foo5(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
 subroutine call_foo5(i)
   integer :: i(10)
   ! %[[argconvert:*]] = fir.convert %arg0 :
   ! fir.call @_QPfoo5(%[[argconvert]]) : (!fir.ref<!fir.array<2x5xi32>>) -> ()
   call foo5(i)
 end subroutine 
 
 
 ! Test when there is no definition (declaration at the end of the mlir module)
 ! First use gives the function type
 
 ! call, pass
 ! CHECK-LABEL: func @_QPcall_foo6(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
 subroutine call_foo6(i)
   integer :: i(10)
   ! CHECK-NOT: convert
   call foo6(i)
-end subroutine
+end subroutine 
+! CHECK-LABEL: func @_QPpass_foo6() {
+subroutine pass_foo6()
+  external :: foo6
+  ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo6) : (!fir.ref<!fir.array<10xi32>>) -> ()
+  ! CHECK: fir.emboxproc %[[f]] : ((!fir.ref<!fir.array<10xi32>>) -> ()) -> !fir.boxproc<() -> ()>
+  call bar(foo6)
+end subroutine
+
+! pass, call
+! CHECK-LABEL: func @_QPpass_foo7() {
+subroutine pass_foo7()
+  external :: foo7
+  ! CHECK-NOT: convert
+  call bar(foo7)
+end subroutine
+! CHECK-LABEL: func @_QPcall_foo7(
+! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) -> f32 {
+function call_foo7(i)
+  integer :: i(10)
+  ! CHECK: %[[f:.*]] = fir.address_of(@_QPfoo7) : () -> ()
+  ! CHECK: %[[funccast:.*]] = fir.convert %[[f]] : (() -> ()) -> ((!fir.ref<!fir.array<10xi32>>) -> f32)
+  ! CHECK: fir.call %[[funccast]](%arg0) : (!fir.ref<!fir.array<10xi32>>) -> f32
+  call_foo7 =  foo7(i)
+end function 
 
 
 ! call, call with different type
 ! CHECK-LABEL: func @_QPcall_foo8(
 ! CHECK-SAME: %{{.*}}: !fir.ref<!fir.array<10xi32>>{{.*}}) {
 subroutine call_foo8(i)
   integer :: i(10)
   ! CHECK-NOT: convert
subroutine test_target_in_iface()
   end interface
   integer :: i
   real :: x(10)
   ! CHECK: fir.call @_QPtest_target
   call test_target(i, x)
 end subroutine
 
 ! CHECK: func private @_QPfoo6(!fir.ref<!fir.array<10xi32>>)
+! CHECK: func private @_QPfoo7()
 
 ! Test declaration from test_target_in_iface
 ! CHECK-LABEL: func private @_QPtest_target(!fir.ref<i32> {fir.target}, !fir.box<!fir.array<?xf32>> {fir.target})