[flang] Lower function and subroutine calls

[clementval]

Summary

This patch introduce basic function/subroutine calls.
Because of the state of lowering only simple scalar arguments
can be used in the calls. This will be enhanced in follow up
patches with arrays, allocatable, pointer ans so on.

subroutine sub1()
end

subroutine sub2()
  call sub1()
end

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

flang/include/flang/Lower/AbstractConverter.h

 
 namespace lower {
 namespace pft {
 struct Variable;
 }
 
 using SomeExpr = Fortran::evaluate::Expr<Fortran::evaluate::SomeType>;
 using SymbolRef = Fortran::common::Reference<const Fortran::semantics::Symbol>;
+class StatementContext;
 
 //===----------------------------------------------------------------------===//
 // AbstractConverter interface
 //===----------------------------------------------------------------------===//
 
 /// The abstract interface for converter implementations to lower Fortran
 /// front-end fragments such as expressions, types, etc. to the FIR dialect of
 /// MLIR.
 class AbstractConverter {
 public:
   //===--------------------------------------------------------------------===//
   // Symbols
   //===--------------------------------------------------------------------===//
 
   /// Get the mlir instance of a symbol.
   virtual mlir::Value getSymbolAddress(SymbolRef sym) = 0;
 
   //===--------------------------------------------------------------------===//
   // Expressions
   //===--------------------------------------------------------------------===//
 
   /// Generate the address of the location holding the expression, someExpr.
-  virtual fir::ExtendedValue genExprAddr(const SomeExpr &,
+  virtual fir::ExtendedValue genExprAddr(const SomeExpr &, StatementContext &,
                                          mlir::Location *loc = nullptr) = 0;
   /// Generate the address of the location holding the expression, someExpr
-  fir::ExtendedValue genExprAddr(const SomeExpr *someExpr, mlir::Location loc) {
-    return genExprAddr(*someExpr, &loc);
+  fir::ExtendedValue genExprAddr(const SomeExpr *someExpr,
+                                 StatementContext &stmtCtx,
+                                 mlir::Location loc) {
+    return genExprAddr(*someExpr, stmtCtx, &loc);
   }
 
   /// Generate the computations of the expression to produce a value
-  virtual fir::ExtendedValue genExprValue(const SomeExpr &,
+  virtual fir::ExtendedValue genExprValue(const SomeExpr &, StatementContext &,
                                           mlir::Location *loc = nullptr) = 0;
   /// Generate the computations of the expression, someExpr, to produce a value
   fir::ExtendedValue genExprValue(const SomeExpr *someExpr,
+                                  StatementContext &stmtCtx,
                                   mlir::Location loc) {
-    return genExprValue(*someExpr, &loc);
+    return genExprValue(*someExpr, stmtCtx, &loc);
   }
 
   /// Get FoldingContext that is required for some expression
   /// analysis.
   virtual Fortran::evaluate::FoldingContext &getFoldingContext() = 0;
 
+  /// Host associated variables are grouped as a tuple. This returns that value,
+  /// which is itself a reference. Use bindTuple() to set this value.
+  virtual mlir::Value hostAssocTupleValue() = 0;
+
   //===--------------------------------------------------------------------===//
   // Types
   //===--------------------------------------------------------------------===//
 
   /// Generate the type of a DataRef
   virtual mlir::Type genType(const Fortran::evaluate::DataRef &) = 0;
   /// Generate the type of an Expr
   virtual mlir::Type genType(const SomeExpr &) = 0;

flang/include/flang/Lower/CallInterface.h

 struct FunctionLikeUnit;
 }
 
 /// PassedEntityTypes helps abstract whether CallInterface is mapping a
 /// Symbol to mlir::Value (callee side) or an ActualArgument to a position
 /// inside the input vector for the CallOp (caller side. It will be up to the
 /// CallInterface user to produce the mlir::Value that will go in this input
 /// vector).
+class CallerInterface;
 class CalleeInterface;
 template <typename T>
 struct PassedEntityTypes {};
 template <>
+struct PassedEntityTypes<CallerInterface> {
+  using FortranEntity = const Fortran::evaluate::ActualArgument *;
+  using FirValue = int;
+};
+template <>
 struct PassedEntityTypes<CalleeInterface> {
   using FortranEntity =
       std::optional<common::Reference<const semantics::Symbol>>;
   using FirValue = mlir::Value;
 };
 
 /// Implementation helper
 template <typename T>
struct PassedEntity {
     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
+  /// utility if callee side.
+  mlir::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.
   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.
   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.
   void declare();
   /// Second pass entry point, once the mlir::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;
   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 =
       std::nullopt;
 };
 
 //===----------------------------------------------------------------------===//
+// Caller side interface
+//===----------------------------------------------------------------------===//
+
+/// The CallerInterface provides the helpers needed by CallInterface
+/// (getting the characteristic...) and a safe way for the user to
+/// place the mlir::Value arguments into the input vector
+/// once they are lowered.
+class CallerInterface : public CallInterface<CallerInterface> {
+public:
+  CallerInterface(const Fortran::evaluate::ProcedureRef &p,
+                  Fortran::lower::AbstractConverter &c)
+      : CallInterface{c}, procRef{p} {
+    declare();
+    mapPassedEntities();
+    actualInputs.resize(getNumFIRArguments());
+  }
+
+  using ExprVisitor = std::function<void(evaluate::Expr<evaluate::SomeType>)>;
+
+  /// CRTP callbacks
+  bool hasAlternateReturns() const;
+  std::string getMangledName() const;
+  mlir::Location getCalleeLocation() const;
+  Fortran::evaluate::characteristics::Procedure characterize() const;
+
+  const Fortran::evaluate::ProcedureRef &getCallDescription() const {
+    return procRef;
+  }
+
+  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.
+  const Fortran::semantics::Symbol *getProcedureSymbol() const;
+
+  /// Helpers to place the lowered arguments at the right place once they
+  /// have been lowered.
+  void placeInput(const PassedEntity &passedEntity, mlir::Value arg);
+  void placeAddressAndLengthInput(const PassedEntity &passedEntity,
+                                  mlir::Value addr, mlir::Value len);
+
+  /// If this is a call to a procedure pointer or dummy, returns the related
+  /// symbol. Nullptr otherwise.
+  const Fortran::semantics::Symbol *getIfIndirectCallSymbol() const;
+
+  /// Get the input vector once it is complete.
+  llvm::ArrayRef<mlir::Value> getInputs() const {
+    if (!verifyActualInputs())
+      llvm::report_fatal_error("lowered arguments are incomplete");
+    return actualInputs;
+  }
+
+  /// Does the caller must map function interface symbols in order to evaluate
+  /// the result specification expressions (extents and lengths) ? If needed,
+  /// this mapping must be done after argument lowering, and before the call
+  /// itself.
+  bool mustMapInterfaceSymbols() const;
+
+  /// Walk the result non-deferred extent specification expressions.
+  void walkResultExtents(ExprVisitor) const;
+
+  /// Walk the result non-deferred length specification expressions.
+  void walkResultLengths(ExprVisitor) const;
+
+  /// Get the mlir::Value that is passed as argument \p sym of the function
+  /// being called. The arguments must have been placed before calling this
+  /// function.
+  mlir::Value getArgumentValue(const semantics::Symbol &sym) const;
+
+  /// Returns the symbol for the result in the explicit interface. If this is
+  /// called on an intrinsic or function without explicit interface, this will
+  /// crash.
+  const Fortran::semantics::Symbol &getResultSymbol() const;
+
+  /// If some storage needs to be allocated for the result,
+  /// returns the storage type.
+  mlir::Type getResultStorageType() const;
+
+  // Copy of base implementation.
+  static constexpr bool hasHostAssociated() { return false; }
+  mlir::Type getHostAssociatedTy() const {
+    llvm_unreachable("getting host associated type in CallerInterface");
+  }
+
+private:
+  /// Check that the input vector is complete.
+  bool verifyActualInputs() const;
+  const Fortran::evaluate::ProcedureRef &procRef;
+  llvm::SmallVector<mlir::Value> actualInputs;
+};
+
+//===----------------------------------------------------------------------===//
 // Callee side interface
 //===----------------------------------------------------------------------===//
 
 /// CalleeInterface only provides the helpers needed by CallInterface
 /// to abstract the specificities of the callee side.
 class CalleeInterface : public CallInterface<CalleeInterface> {
 public:
   CalleeInterface(Fortran::lower::pft::FunctionLikeUnit &f,

flang/include/flang/Lower/ConvertExpr.h

 template <typename>
 class Expr;
 struct SomeType;
 } // namespace Fortran::evaluate
 
 namespace Fortran::lower {
 
 class AbstractConverter;
+class StatementContext;
 class SymMap;
 using SomeExpr = Fortran::evaluate::Expr<Fortran::evaluate::SomeType>;
 
 /// Create an extended expression value.
 fir::ExtendedValue createSomeExtendedExpression(mlir::Location loc,
                                                 AbstractConverter &converter,
                                                 const SomeExpr &expr,
-                                                SymMap &symMap);
+                                                SymMap &symMap,
+                                                StatementContext &stmtCtx);
 
 /// Create an extended expression address.
 fir::ExtendedValue createSomeExtendedAddress(mlir::Location loc,
                                              AbstractConverter &converter,
                                              const SomeExpr &expr,
-                                             SymMap &symMap);
+                                             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,
+                                 SymMap &symMap, StatementContext &stmtCtx);
 
 // 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()};
 }
 
 } // namespace Fortran::lower
 
 #endif // FORTRAN_LOWER_CONVERTEXPR_H

flang/include/flang/Lower/ConvertVariable.h

 ///
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_LOWER_CONVERT_VARIABLE_H
 #define FORTRAN_LOWER_CONVERT_VARIABLE_H
 
 namespace Fortran ::lower {
 class AbstractConverter;
+class CallerInterface;
 class SymMap;
 namespace pft {
 struct Variable;
 }
 
 /// Instantiate variable \p var and add it to \p symMap.
 /// The AbstractConverter builder must be set.
 /// The AbstractConverter own symbol mapping is not used during the
 /// instantiation and can be different form \p symMap.
 void instantiateVariable(AbstractConverter &, const pft::Variable &var,
                          SymMap &symMap);
 
+/// Instantiate the variables that appear in the specification expressions
+/// of the result of a function call. The instantiated variables are added
+/// to \p symMap.
+void mapCallInterfaceSymbols(AbstractConverter &,
+                             const Fortran::lower::CallerInterface &caller,
+                             SymMap &symMap);
+
 } // namespace Fortran::lower
 #endif // FORTRAN_LOWER_CONVERT_VARIABLE_H

flang/include/flang/Lower/StatementContext.h

+//===-- StatementContext.h --------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_STATEMENTCONTEXT_H
+#define FORTRAN_LOWER_STATEMENTCONTEXT_H
+
+#include <functional>
+
+namespace Fortran::lower {
+
+/// When lowering a statement, temporaries for intermediate results may be
+/// allocated on the heap.  A StatementContext enables their deallocation
+/// either explicitly with finalize() calls, or implicitly at the end of
+/// the context.  A context may prohibit temporary allocation.  Otherwise,
+/// an initial "outer" context scope may have nested context scopes, which
+/// must make explicit subscope finalize() calls.
+class StatementContext {
+public:
+  explicit StatementContext(bool cleanupProhibited = false) {
+    if (cleanupProhibited)
+      return;
+    cufs.push_back({});
+  }
+
+  ~StatementContext() {
+    if (!cufs.empty())
+      finalize(/*popScope=*/true);
+    assert(cufs.empty() && "invalid StatementContext destructor call");
+  }
+
+  using CleanupFunction = std::function<void()>;
+
+  /// Push a context subscope.
+  void pushScope() {
+    assert(!cufs.empty() && "invalid pushScope statement context");
+    cufs.push_back({});
+  }
+
+  /// Append a cleanup function to the "list" of cleanup functions.
+  void attachCleanup(CleanupFunction cuf) {
+    assert(!cufs.empty() && "invalid attachCleanup statement context");
+    if (cufs.back()) {
+      CleanupFunction oldCleanup = *cufs.back();
+      cufs.back() = [=]() {
+        cuf();
+        oldCleanup();
+      };
+    } else {
+      cufs.back() = cuf;
+    }
+  }
+
+  /// Make cleanup calls.  Pop or reset the stack top list.
+  void finalize(bool popScope = false) {
+    assert(!cufs.empty() && "invalid finalize statement context");
+    if (cufs.back())
+      (*cufs.back())();
+    if (popScope)
+      cufs.pop_back();
+    else
+      cufs.back().reset();
+  }
+
+private:
+  // A statement context should never be copied or moved.
+  StatementContext(const StatementContext &) = delete;
+  StatementContext &operator=(const StatementContext &) = delete;
+  StatementContext(StatementContext &&) = delete;
+
+  // Stack of cleanup function "lists" (nested cleanup function calls).
+  llvm::SmallVector<llvm::Optional<CleanupFunction>> cufs;
+};
+
+} // namespace Fortran::lower
+
+#endif // FORTRAN_LOWER_STATEMENTCONTEXT_H

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

public:
   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. For e.g for
-  /// converting an integer/real to a complex, the real part is filled using
-  /// the integer/real after type conversion and the imaginary part is zero.
+  /// 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
+  /// (real) to a complex, the real part is filled using the integer (real)
+  /// after type conversion and the imaginary part is zero.
   mlir::Value convertWithSemantics(mlir::Location loc, mlir::Type toTy,
-                                   mlir::Value val);
+                                   mlir::Value val,
+                                   bool allowCharacterConversion = false);
 
   /// Get the entry block of the current Function
   mlir::Block *getEntryBlock() { return &getFunction().front(); }
 
   /// Get the block for adding Allocas. If OpenMP is enabled then get the
   /// the alloca block from an Operation which can be Outlined. Otherwise
   /// use the entry block of the current Function
   mlir::Block *getAllocaBlock();
public:
   /// Get the integer type whose bit width corresponds to the width of pointer
   /// types, or is bigger.
   mlir::Type getIntPtrType() {
     // TODO: Delay the need of such type until codegen or find a way to use
     // llvm::DataLayout::getPointerSizeInBits here.
     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).
   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.
   mlir::Value createNullConstant(mlir::Location loc, mlir::Type ptrType = {});
 
   /// Create an integer constant of type \p type and value \p i.
   mlir::Value createIntegerConstant(mlir::Location loc, mlir::Type integerType,
                                     std::int64_t i);
 
public:
   /// 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);
+  }
+  static mlir::FuncOp getNamedFunction(mlir::ModuleOp module,
+                                       mlir::SymbolRefAttr symbol);
+
   fir::GlobalOp getNamedGlobal(llvm::StringRef name) {
     return getNamedGlobal(getModule(), name);
   }
 
   static fir::GlobalOp getNamedGlobal(mlir::ModuleOp module,
                                       llvm::StringRef name);
 
   /// Lazy creation of fir.convert op.
llvm::SmallVector<mlir::Value> readExtents(fir::FirOpBuilder &builder,
                                            const fir::BoxValue &box);
 
 /// Get extents from \p box. For fir::BoxValue and
 /// fir::MutableBoxValue, this will generate code to read the extents.
 llvm::SmallVector<mlir::Value> getExtents(fir::FirOpBuilder &builder,
                                           mlir::Location loc,
                                           const fir::ExtendedValue &box);
 
+/// Read a fir::BoxValue into an fir::UnboxValue, a fir::ArrayBoxValue or a
+/// fir::CharArrayBoxValue. This should only be called if the fir::BoxValue is
+/// known to be contiguous given the context (or if the resulting address will
+/// not be used). If the value is polymorphic, its dynamic type will be lost.
+/// This must not be used on unlimited polymorphic and assumed rank entities.
+fir::ExtendedValue readBoxValue(fir::FirOpBuilder &builder, mlir::Location loc,
+                                const fir::BoxValue &box);
+
 //===----------------------------------------------------------------------===//
 // 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);

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

 /// Character dummy procedure have special ABI constraints.
 static constexpr llvm::StringRef getCharacterProcedureDummyAttrName() {
   return "fir.char_proc";
 }
 
 /// Attribute to keep track of Fortran scoping information for a symbol.
 static constexpr llvm::StringRef getSymbolAttrName() { return "fir.sym_name"; }
 
+/// Attribute to mark a function that takes a host associations argument.
+static constexpr llvm::StringRef getHostAssocAttrName() {
+  return "fir.host_assoc";
+}
+
 /// Tell if \p value is:
 ///   - a function argument that has attribute \p attributeName
 ///   - or, the result of fir.alloca/fir.allocamem op that has attribute \p
 ///     attributeName
 ///   - or, the result of a fir.address_of of a fir.global that has attribute \p
 ///     attributeName
 ///   - or, a fir.box loaded from a fir.ref<fir.box> that matches one of the
 ///     previous cases.
 bool valueHasFirAttribute(mlir::Value value, llvm::StringRef attributeName);
 
+/// Scan the arguments of a FuncOp to determine if any arguments have the
+/// attribute `attr` placed on them. This can be used to determine if the
+/// function has any host associations, for example.
+bool anyFuncArgsHaveAttr(mlir::FuncOp func, llvm::StringRef attr);
+
 } // namespace fir
 
 #endif // FORTRAN_OPTIMIZER_DIALECT_FIROPSSUPPORT_H

flang/lib/Lower/Bridge.cpp

 #include "flang/Evaluate/tools.h"
 #include "flang/Lower/CallInterface.h"
 #include "flang/Lower/ConvertExpr.h"
 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/PFTBuilder.h"
 #include "flang/Lower/Runtime.h"
+#include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Support/FIRContext.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
 #include "mlir/IR/PatternMatch.h"
 #include "mlir/Transforms/RegionUtils.h"
 #include "llvm/Support/CommandLine.h"
public:
   // AbstractConverter overrides
   //===--------------------------------------------------------------------===//
 
   mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final {
     return lookupSymbol(sym).getAddr();
   }
 
   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);
+                                     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);
+                                        localSymbols, context);
   }
 
   Fortran::evaluate::FoldingContext &getFoldingContext() override final {
     return foldingContext;
   }
 
   mlir::Type genType(const Fortran::evaluate::DataRef &) override final {
     TODO_NOLOC("Not implemented genType DataRef. Needed for more complex "
void endNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
     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();
   }
 
   /// 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) {
for (int entryIndex = 0, last = funit.entryPointList.size();
         genFIR(eval);
       endNewFunction(funit);
     }
     funit.setActiveEntry(0);
     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
       lowerFunc(f); // internal procedure
   }
 
+  mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
+
 private:
   FirConverter() = delete;
   FirConverter(const FirConverter &) = delete;
   FirConverter &operator=(const FirConverter &) = delete;
 
   //===--------------------------------------------------------------------===//
   // Helper member functions
   //===--------------------------------------------------------------------===//
private:
 
   static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
     const Fortran::semantics::Symbol *sym =
         Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr);
     return sym && Fortran::semantics::IsAllocatable(*sym);
   }
 
   void genAssignment(const Fortran::evaluate::Assignment &assign) {
+    Fortran::lower::StatementContext stmtCtx;
     mlir::Location loc = toLocation();
-
     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)
std::visit(
                 TODO(toLocation(), "Array assignment");
                 return;
               }
 
               // Scalar assignment
               const bool isNumericScalar =
                   isNumericScalarCategory(lhsType->category());
               fir::ExtendedValue rhs = isNumericScalar
-                                           ? genExprValue(assign.rhs)
-                                           : genExprAddr(assign.rhs);
+                                           ? genExprValue(assign.rhs, stmtCtx)
+                                           : genExprAddr(assign.rhs, stmtCtx);
 
               if (isNumericScalar) {
                 // Fortran 2018 10.2.1.3 p8 and p9
                 // Conversions should have been inserted by semantic analysis,
                 // but they can be incorrect between the rhs and lhs. Correct
                 // that here.
-                mlir::Value addr = fir::getBase(genExprAddr(assign.lhs));
+                mlir::Value addr =
+                    fir::getBase(genExprAddr(assign.lhs, stmtCtx));
                 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 =
std::visit(
             [&](const Fortran::evaluate::Assignment::BoundsRemapping
                     &boundExprs) {
               TODO(toLocation(), "Pointer assignment with bounds-remapping");
             },
         },
         assign.u);
   }
 
+  /// Lowering of CALL statement
   void genFIR(const Fortran::parser::CallStmt &stmt) {
-    TODO(toLocation(), "CallStmt lowering");
+    Fortran::lower::StatementContext stmtCtx;
+    setCurrentPosition(stmt.v.source);
+    assert(stmt.typedCall && "Call was not analyzed");
+    // Call statement lowering shares code with function call lowering.
+    mlir::Value res = Fortran::lower::createSubroutineCall(
+        *this, *stmt.typedCall, localSymbols, stmtCtx);
+    if (!res)
+      return; // "Normal" subroutine call.
   }
 
   void genFIR(const Fortran::parser::ComputedGotoStmt &stmt) {
     TODO(toLocation(), "ComputedGotoStmt lowering");
   }
 
   void genFIR(const Fortran::parser::ArithmeticIfStmt &stmt) {
     TODO(toLocation(), "ArithmeticIfStmt lowering");
private:
   //===--------------------------------------------------------------------===//
 
   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;
+
+  /// Tuple of host assoicated variables.
+  mlir::Value hostAssocTuple;
 };
 
 } // namespace
 
 Fortran::evaluate::FoldingContext
 Fortran::lower::LoweringBridge::createFoldingContext() const {
   return {getDefaultKinds(), getIntrinsicTable()};
 }

flang/lib/Lower/CallInterface.cpp

 
 // Return the binding label (from BIND(C...)) or the mangled name of a symbol.
 static std::string getMangledName(const Fortran::semantics::Symbol &symbol) {
   const std::string *bindName = symbol.GetBindName();
   return bindName ? *bindName : Fortran::lower::mangle::mangleName(symbol);
 }
 
 //===----------------------------------------------------------------------===//
+// Caller side interface implementation
+//===----------------------------------------------------------------------===//
+
+bool Fortran::lower::CallerInterface::hasAlternateReturns() const {
+  return procRef.hasAlternateReturns();
+}
+
+std::string Fortran::lower::CallerInterface::getMangledName() const {
+  const Fortran::evaluate::ProcedureDesignator &proc = procRef.proc();
+  if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol())
+    return ::getMangledName(symbol->GetUltimate());
+  assert(proc.GetSpecificIntrinsic() &&
+         "expected intrinsic procedure in designator");
+  return proc.GetName();
+}
+
+const Fortran::semantics::Symbol *
+Fortran::lower::CallerInterface::getProcedureSymbol() const {
+  return procRef.proc().GetSymbol();
+}
+
+bool Fortran::lower::CallerInterface::isIndirectCall() const {
+  if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
+    return Fortran::semantics::IsPointer(*symbol) ||
+           Fortran::semantics::IsDummy(*symbol);
+  return false;
+}
+
+const Fortran::semantics::Symbol *
+Fortran::lower::CallerInterface::getIfIndirectCallSymbol() const {
+  if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
+    if (Fortran::semantics::IsPointer(*symbol) ||
+        Fortran::semantics::IsDummy(*symbol))
+      return symbol;
+  return nullptr;
+}
+
+mlir::Location Fortran::lower::CallerInterface::getCalleeLocation() const {
+  const Fortran::evaluate::ProcedureDesignator &proc = procRef.proc();
+  // FIXME: If the callee is defined in the same file but after the current
+  // unit we cannot get its location here and the funcOp is created at the
+  // wrong location (i.e, the caller location).
+  if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol())
+    return converter.genLocation(symbol->name());
+  // Use current location for intrinsics.
+  return converter.getCurrentLocation();
+}
+
+// Get dummy argument characteristic for a procedure with implicit interface
+// from the actual argument characteristic. The actual argument may not be a F77
+// entity. The attribute must be dropped and the shape, if any, must be made
+// explicit.
+static Fortran::evaluate::characteristics::DummyDataObject
+asImplicitArg(Fortran::evaluate::characteristics::DummyDataObject &&dummy) {
+  Fortran::evaluate::Shape shape =
+      dummy.type.attrs().none() ? dummy.type.shape()
+                                : Fortran::evaluate::Shape(dummy.type.Rank());
+  return Fortran::evaluate::characteristics::DummyDataObject(
+      Fortran::evaluate::characteristics::TypeAndShape(dummy.type.type(),
+                                                       std::move(shape)));
+}
+
+static Fortran::evaluate::characteristics::DummyArgument
+asImplicitArg(Fortran::evaluate::characteristics::DummyArgument &&dummy) {
+  return std::visit(
+      Fortran::common::visitors{
+          [&](Fortran::evaluate::characteristics::DummyDataObject &obj) {
+            return Fortran::evaluate::characteristics::DummyArgument(
+                std::move(dummy.name), asImplicitArg(std::move(obj)));
+          },
+          [&](Fortran::evaluate::characteristics::DummyProcedure &proc) {
+            return Fortran::evaluate::characteristics::DummyArgument(
+                std::move(dummy.name), std::move(proc));
+          },
+          [](Fortran::evaluate::characteristics::AlternateReturn &x) {
+            return Fortran::evaluate::characteristics::DummyArgument(
+                std::move(x));
+          }},
+      dummy.u);
+}
+
+Fortran::evaluate::characteristics::Procedure
+Fortran::lower::CallerInterface::characterize() const {
+  Fortran::evaluate::FoldingContext &foldingContext =
+      converter.getFoldingContext();
+  std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =
+      Fortran::evaluate::characteristics::Procedure::Characterize(
+          procRef.proc(), foldingContext);
+  assert(characteristic && "Failed to get characteristic from procRef");
+  // The characteristic may not contain the argument characteristic if the
+  // ProcedureDesignator has no interface.
+  if (!characteristic->HasExplicitInterface()) {
+    for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
+         procRef.arguments()) {
+      if (arg.value().isAlternateReturn()) {
+        characteristic->dummyArguments.emplace_back(
+            Fortran::evaluate::characteristics::AlternateReturn{});
+      } else {
+        // Argument cannot be optional with implicit interface
+        const Fortran::lower::SomeExpr *expr = arg.value().UnwrapExpr();
+        assert(
+            expr &&
+            "argument in call with implicit interface cannot be assumed type");
+        std::optional<Fortran::evaluate::characteristics::DummyArgument>
+            argCharacteristic =
+                Fortran::evaluate::characteristics::DummyArgument::FromActual(
+                    "actual", *expr, foldingContext);
+        assert(argCharacteristic &&
+               "failed to characterize argument in implicit call");
+        characteristic->dummyArguments.emplace_back(
+            asImplicitArg(std::move(*argCharacteristic)));
+      }
+    }
+  }
+  return *characteristic;
+}
+
+void Fortran::lower::CallerInterface::placeInput(
+    const PassedEntity &passedEntity, mlir::Value arg) {
+  assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument &&
+         passedEntity.firArgument >= 0 &&
+         passedEntity.passBy != CallInterface::PassEntityBy::AddressAndLength &&
+         "bad arg position");
+  actualInputs[passedEntity.firArgument] = arg;
+}
+
+void Fortran::lower::CallerInterface::placeAddressAndLengthInput(
+    const PassedEntity &passedEntity, mlir::Value addr, mlir::Value len) {
+  assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument &&
+         static_cast<int>(actualInputs.size()) > passedEntity.firLength &&
+         passedEntity.firArgument >= 0 && passedEntity.firLength >= 0 &&
+         passedEntity.passBy == CallInterface::PassEntityBy::AddressAndLength &&
+         "bad arg position");
+  actualInputs[passedEntity.firArgument] = addr;
+  actualInputs[passedEntity.firLength] = len;
+}
+
+bool Fortran::lower::CallerInterface::verifyActualInputs() const {
+  if (getNumFIRArguments() != actualInputs.size())
+    return false;
+  for (mlir::Value arg : actualInputs) {
+    if (!arg)
+      return false;
+  }
+  return true;
+}
+
+void Fortran::lower::CallerInterface::walkResultLengths(
+    ExprVisitor visitor) const {
+  assert(characteristic && "characteristic was not computed");
+  const Fortran::evaluate::characteristics::FunctionResult &result =
+      characteristic->functionResult.value();
+  const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
+      result.GetTypeAndShape();
+  assert(typeAndShape && "no result type");
+  Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
+  // Visit result length specification expressions that are explicit.
+  if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
+    if (std::optional<Fortran::evaluate::ExtentExpr> length =
+            dynamicType.GetCharLength())
+      visitor(toEvExpr(*length));
+  } else if (dynamicType.category() == common::TypeCategory::Derived) {
+    const Fortran::semantics::DerivedTypeSpec &derivedTypeSpec =
+        dynamicType.GetDerivedTypeSpec();
+    if (Fortran::semantics::CountLenParameters(derivedTypeSpec) > 0)
+      TODO(converter.getCurrentLocation(),
+           "function result with derived type length parameters");
+  }
+}
+
+// Compute extent expr from shapeSpec of an explicit shape.
+// TODO: Allow evaluate shape analysis to work in a mode where it disregards
+// the non-constant aspects when building the shape to avoid having this here.
+static Fortran::evaluate::ExtentExpr
+getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) {
+  const auto &ubound = shapeSpec.ubound().GetExplicit();
+  const auto &lbound = shapeSpec.lbound().GetExplicit();
+  assert(lbound && ubound && "shape must be explicit");
+  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();
+    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())
+    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)
+    fir::emitFatalError(
+        loc, "mapping actual and dummy arguments requires an interface");
+  const std::vector<Fortran::semantics::Symbol *> &dummies =
+      iface->get<semantics::SubprogramDetails>().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)
+    fir::emitFatalError(
+        loc, "mapping actual and dummy arguments requires an interface");
+  return iface->get<semantics::SubprogramDetails>().result();
+}
+
+//===----------------------------------------------------------------------===//
 // Callee side interface implementation
 //===----------------------------------------------------------------------===//
 
 bool Fortran::lower::CalleeInterface::hasAlternateReturns() const {
   return !funit.isMainProgram() &&
          Fortran::semantics::HasAlternateReturns(funit.getSubprogramSymbol());
 }
 
PassedEntity &passedEntity =
           ? passedResult.value()
           : passedArguments[placeHolder.passedEntityPosition];
   if (placeHolder.property == Property::CharLength)
     passedEntity.firLength = firValue;
   else
     passedEntity.firArgument = firValue;
 }
 
+/// Helpers to access ActualArgument/Symbols
+static const Fortran::evaluate::ActualArguments &
+getEntityContainer(const Fortran::evaluate::ProcedureRef &proc) {
+  return proc.arguments();
+}
+
 static const std::vector<Fortran::semantics::Symbol *> &
 getEntityContainer(Fortran::lower::pft::FunctionLikeUnit &funit) {
   return funit.getSubprogramSymbol()
       .get<Fortran::semantics::SubprogramDetails>()
       .dummyArgs();
 }
 
+static const Fortran::evaluate::ActualArgument *getDataObjectEntity(
+    const std::optional<Fortran::evaluate::ActualArgument> &arg) {
+  if (arg)
+    return &*arg;
+  return nullptr;
+}
+
 static const Fortran::semantics::Symbol &
 getDataObjectEntity(const Fortran::semantics::Symbol *arg) {
   assert(arg && "expect symbol for data object entity");
   return *arg;
 }
 
 //===----------------------------------------------------------------------===//
 // CallInterface implementation: this part is common to both caller and caller
private:
   Fortran::lower::AbstractConverter &getConverter() {
     return interface.converter;
   }
   CallInterface &interface;
   mlir::MLIRContext &mlirContext;
 };
 
 template <typename T>
+bool Fortran::lower::CallInterface<T>::PassedEntity::isOptional() const {
+  if (!characteristics)
+    return false;
+  return characteristics->IsOptional();
+}
+template <typename T>
+bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeModifiedByCall()
+    const {
+  if (!characteristics)
+    return true;
+  return characteristics->GetIntent() != Fortran::common::Intent::In;
+}
+template <typename T>
+bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeReadByCall() const {
+  if (!characteristics)
+    return true;
+  return characteristics->GetIntent() != Fortran::common::Intent::Out;
+}
+
+template <typename T>
 void Fortran::lower::CallInterface<T>::determineInterface(
     bool isImplicit,
     const Fortran::evaluate::characteristics::Procedure &procedure) {
   CallInterfaceImpl<T> impl(*this);
   if (isImplicit)
     impl.buildImplicitInterface(procedure);
   else
     impl.buildExplicitInterface(procedure);
 }
 
 template <typename T>
 mlir::FunctionType Fortran::lower::CallInterface<T>::genFunctionType() {
   llvm::SmallVector<mlir::Type> returnTys;
   llvm::SmallVector<mlir::Type> inputTys;
   for (const FirPlaceHolder &placeHolder : outputs)
     returnTys.emplace_back(placeHolder.type);
   for (const FirPlaceHolder &placeHolder : inputs)
     inputTys.emplace_back(placeHolder.type);
   return mlir::FunctionType::get(&converter.getMLIRContext(), inputTys,
                                  returnTys);
 }
 
 template class Fortran::lower::CallInterface<Fortran::lower::CalleeInterface>;
+template class Fortran::lower::CallInterface<Fortran::lower::CallerInterface>;

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/Evaluate/fold.h"
-#include "flang/Evaluate/real.h"
 #include "flang/Evaluate/traverse.h"
 #include "flang/Lower/AbstractConverter.h"
+#include "flang/Lower/CallInterface.h"
 #include "flang/Lower/ConvertType.h"
+#include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/IntrinsicCall.h"
+#include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/Complex.h"
+#include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "flang/Semantics/type.h"
 #include "mlir/Dialect/StandardOps/IR/Ops.h"
 #include "llvm/Support/Debug.h"
 
 #define DEBUG_TYPE "flang-lower-expr"
placeScalarValueInMemory(fir::FirOpBuilder &builder, mlir::Location loc,
   mlir::Value temp = builder.createTemporary(
       loc, storageType,
       llvm::ArrayRef<mlir::NamedAttribute>{
           Fortran::lower::getAdaptToByRefAttr(builder)});
   builder.create<fir::StoreOp>(loc, val, temp);
   return fir::substBase(exv, temp);
 }
 
+/// Is this a variable wrapped in parentheses?
+template <typename A>
+static bool isParenthesizedVariable(const A &) {
+  return false;
+}
+template <typename T>
+static bool isParenthesizedVariable(const Fortran::evaluate::Expr<T> &expr) {
+  using ExprVariant = decltype(Fortran::evaluate::Expr<T>::u);
+  using Parentheses = Fortran::evaluate::Parentheses<T>;
+  if constexpr (Fortran::common::HasMember<Parentheses, ExprVariant>) {
+    if (const auto *parentheses = std::get_if<Parentheses>(&expr.u))
+      return Fortran::evaluate::IsVariable(parentheses->left());
+    return false;
+  } else {
+    return std::visit([&](const auto &x) { return isParenthesizedVariable(x); },
+                      expr.u);
+  }
+}
+
 /// Generate a load of a value from an address. Beware that this will lose
 /// any dynamic type information for polymorphic entities (note that unlimited
 /// polymorphic cannot be loaded and must not be provided here).
 static fir::ExtendedValue genLoad(fir::FirOpBuilder &builder,
                                   mlir::Location loc,
                                   const fir::ExtendedValue &addr) {
   return addr.match(
       [](const fir::CharBoxValue &box) -> fir::ExtendedValue { return box; },

 isElementalProcWithArrayArgs(const Fortran::evaluate::ProcedureRef &procRef) {
   if (procRef.IsElemental())
     for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
          procRef.arguments())
       if (arg && arg->Rank() != 0)
         return true;
   return false;
 }
+
+/// If \p arg is the address of a function with a denoted host-association tuple
+/// argument, then return the host-associations tuple value of the current
+/// procedure. Otherwise, return nullptr.
+static mlir::Value
+argumentHostAssocs(Fortran::lower::AbstractConverter &converter,
+                   mlir::Value arg) {
+  if (auto addr = mlir::dyn_cast_or_null<fir::AddrOfOp>(arg.getDefiningOp())) {
+    auto &builder = converter.getFirOpBuilder();
+    if (auto funcOp = builder.getNamedFunction(addr.getSymbol()))
+      if (fir::anyFuncArgsHaveAttr(funcOp, fir::getHostAssocAttrName()))
+        return converter.hostAssocTupleValue();
+  }
+  return {};
+}
+
 namespace {
 
 /// Lowering of Fortran::evaluate::Expr<T> expressions
 class ScalarExprLowering {
 public:
   using ExtValue = fir::ExtendedValue;
 
   explicit ScalarExprLowering(mlir::Location loc,
                               Fortran::lower::AbstractConverter &converter,
-                              Fortran::lower::SymMap &symMap)
+                              Fortran::lower::SymMap &symMap,
+                              Fortran::lower::StatementContext &stmtCtx)
       : location{loc}, converter{converter},
-        builder{converter.getFirOpBuilder()}, symMap{symMap} {}
+        builder{converter.getFirOpBuilder()}, stmtCtx{stmtCtx}, symMap{symMap} {
+  }
+
+  ExtValue genExtAddr(const Fortran::lower::SomeExpr &expr) {
+    return gen(expr);
+  }
+
+  /// Lower `expr` to be passed as a fir.box argument. Do not create a temp
+  /// for the expr if it is a variable that can be described as a fir.box.
+  ExtValue genBoxArg(const Fortran::lower::SomeExpr &expr) {
+    bool saveUseBoxArg = useBoxArg;
+    useBoxArg = true;
+    ExtValue result = gen(expr);
+    useBoxArg = saveUseBoxArg;
+    return result;
+  }
+
+  ExtValue genExtValue(const Fortran::lower::SomeExpr &expr) {
+    return genval(expr);
+  }
 
   mlir::Location getLoc() { return location; }
 
   template <typename A>
   mlir::Value genunbox(const A &expr) {
     ExtValue e = genval(expr);
     if (const fir::UnboxedValue *r = e.getUnboxed())
       return *r;
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
 
   /// Lower function call `funcRef` and return a reference to the resultant
   /// value. This is required for lowering expressions such as `f1(f2(v))`.
   template <typename A>
   ExtValue gen(const Fortran::evaluate::FunctionRef<A> &funcRef) {
     TODO(getLoc(), "gen FunctionRef<A>");
   }
 
+  /// 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;
+  }
+
+  /// Helper to package a Value and its properties into an ExtendedValue.
+  static ExtValue toExtendedValue(mlir::Location loc, mlir::Value base,
+                                  llvm::ArrayRef<mlir::Value> extents,
+                                  llvm::ArrayRef<mlir::Value> lengths) {
+    mlir::Type type = base.getType();
+    if (type.isa<fir::BoxType>())
+      return fir::BoxValue(base, /*lbounds=*/{}, lengths, extents);
+    type = fir::unwrapRefType(type);
+    if (type.isa<fir::BoxType>())
+      return fir::MutableBoxValue(base, lengths, /*mutableProperties*/ {});
+    if (auto seqTy = type.dyn_cast<fir::SequenceType>()) {
+      if (seqTy.getDimension() != extents.size())
+        fir::emitFatalError(loc, "incorrect number of extents for array");
+      if (seqTy.getEleTy().isa<fir::CharacterType>()) {
+        if (lengths.empty())
+          fir::emitFatalError(loc, "missing length for character");
+        assert(lengths.size() == 1);
+        return fir::CharArrayBoxValue(base, lengths[0], extents);
+      }
+      return fir::ArrayBoxValue(base, extents);
+    }
+    if (type.isa<fir::CharacterType>()) {
+      if (lengths.empty())
+        fir::emitFatalError(loc, "missing length for character");
+      assert(lengths.size() == 1);
+      return fir::CharBoxValue(base, lengths[0]);
+    }
+    return base;
+  }
+
+  // Find the argument that corresponds to the host associations.
+  // Verify some assumptions about how the signature was built here.
+  [[maybe_unused]] static unsigned findHostAssocTuplePos(mlir::FuncOp fn) {
+    // Scan the argument list from last to first as the host associations are
+    // appended for now.
+    for (unsigned i = fn.getNumArguments(); i > 0; --i)
+      if (fn.getArgAttr(i - 1, fir::getHostAssocAttrName())) {
+        // Host assoc tuple must be last argument (for now).
+        assert(i == fn.getNumArguments() && "tuple must be last");
+        return i - 1;
+      }
+    llvm_unreachable("anyFuncArgsHaveAttr failed");
+  }
+
+  /// Lower a non-elemental procedure reference and read allocatable and pointer
+  /// results into normal values.
+  ExtValue genProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
+                           llvm::Optional<mlir::Type> resultType) {
+    ExtValue res = genRawProcedureRef(procRef, resultType);
+    return res;
+  }
+
+  /// Given a call site for which the arguments were already lowered, generate
+  /// the call and return the result. This function deals with explicit result
+  /// allocation and lowering if needed. It also deals with passing the host
+  /// link to internal procedures.
+  ExtValue genCallOpAndResult(Fortran::lower::CallerInterface &caller,
+                              mlir::FunctionType callSiteType,
+                              llvm::Optional<mlir::Type> resultType) {
+    mlir::Location loc = getLoc();
+    using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
+    // Handle cases where caller must allocate the result or a fir.box for it.
+    bool mustPopSymMap = false;
+    if (caller.mustMapInterfaceSymbols()) {
+      symMap.pushScope();
+      mustPopSymMap = true;
+      Fortran::lower::mapCallInterfaceSymbols(converter, caller, symMap);
+    }
+    // If this is an indirect call, retrieve the function address. Also retrieve
+    // the result length if this is a character function (note that this length
+    // will be used only if there is no explicit length in the local interface).
+    mlir::Value funcPointer;
+    mlir::Value charFuncPointerLength;
+    if (caller.getIfIndirectCallSymbol()) {
+      TODO(loc, "genCallOpAndResult indirect call");
+    }
+
+    mlir::IndexType idxTy = builder.getIndexType();
+    auto lowerSpecExpr = [&](const auto &expr) -> mlir::Value {
+      return builder.createConvert(
+          loc, idxTy, fir::getBase(converter.genExprValue(expr, stmtCtx)));
+    };
+    llvm::SmallVector<mlir::Value> resultLengths;
+    auto allocatedResult = [&]() -> llvm::Optional<ExtValue> {
+      llvm::SmallVector<mlir::Value> extents;
+      llvm::SmallVector<mlir::Value> lengths;
+      if (!caller.callerAllocateResult())
+        return {};
+      mlir::Type type = caller.getResultStorageType();
+      if (type.isa<fir::SequenceType>())
+        caller.walkResultExtents([&](const Fortran::lower::SomeExpr &e) {
+          extents.emplace_back(lowerSpecExpr(e));
+        });
+      caller.walkResultLengths([&](const Fortran::lower::SomeExpr &e) {
+        lengths.emplace_back(lowerSpecExpr(e));
+      });
+
+      // Result length parameters should not be provided to box storage
+      // allocation and save_results, but they are still useful information to
+      // keep in the ExtendedValue if non-deferred.
+      if (!type.isa<fir::BoxType>()) {
+        if (fir::isa_char(fir::unwrapSequenceType(type)) && lengths.empty()) {
+          // Calling an assumed length function. This is only possible if this
+          // is a call to a character dummy procedure.
+          if (!charFuncPointerLength)
+            fir::emitFatalError(loc, "failed to retrieve character function "
+                                     "length while calling it");
+          lengths.push_back(charFuncPointerLength);
+        }
+        resultLengths = lengths;
+      }
+
+      if (!extents.empty() || !lengths.empty()) {
+        TODO(loc, "genCallOpResult extents and length");
+      }
+      mlir::Value temp =
+          builder.createTemporary(loc, type, ".result", extents, resultLengths);
+      return toExtendedValue(loc, temp, extents, lengths);
+    }();
+
+    if (mustPopSymMap)
+      symMap.popScope();
+
+    // Place allocated result or prepare the fir.save_result arguments.
+    mlir::Value arrayResultShape;
+    if (allocatedResult) {
+      if (std::optional<Fortran::lower::CallInterface<
+              Fortran::lower::CallerInterface>::PassedEntity>
+              resultArg = caller.getPassedResult()) {
+        if (resultArg->passBy == PassBy::AddressAndLength)
+          caller.placeAddressAndLengthInput(*resultArg,
+                                            fir::getBase(*allocatedResult),
+                                            fir::getLen(*allocatedResult));
+        else if (resultArg->passBy == PassBy::BaseAddress)
+          caller.placeInput(*resultArg, fir::getBase(*allocatedResult));
+        else
+          fir::emitFatalError(
+              loc, "only expect character scalar result to be passed by ref");
+      } else {
+        assert(caller.mustSaveResult());
+        arrayResultShape = allocatedResult->match(
+            [&](const fir::CharArrayBoxValue &) {
+              return builder.createShape(loc, *allocatedResult);
+            },
+            [&](const fir::ArrayBoxValue &) {
+              return builder.createShape(loc, *allocatedResult);
+            },
+            [&](const auto &) { return mlir::Value{}; });
+      }
+    }
+
+    // In older Fortran, procedure argument types are inferred. This may lead
+    // different view of what the function signature is in different locations.
+    // Casts are inserted as needed below to accommodate this.
+
+    // The mlir::FuncOp type prevails, unless it has a different number of
+    // arguments which can happen in legal program if it was passed as a dummy
+    // procedure argument earlier with no further type information.
+    mlir::SymbolRefAttr funcSymbolAttr;
+    bool addHostAssociations = false;
+    if (!funcPointer) {
+      mlir::FunctionType funcOpType = caller.getFuncOp().getType();
+      mlir::SymbolRefAttr symbolAttr =
+          builder.getSymbolRefAttr(caller.getMangledName());
+      if (callSiteType.getNumResults() == funcOpType.getNumResults() &&
+          callSiteType.getNumInputs() + 1 == funcOpType.getNumInputs() &&
+          fir::anyFuncArgsHaveAttr(caller.getFuncOp(),
+                                   fir::getHostAssocAttrName())) {
+        // The number of arguments is off by one, and we're lowering a function
+        // with host associations. Modify call to include host associations
+        // argument by appending the value at the end of the operands.
+        assert(funcOpType.getInput(findHostAssocTuplePos(caller.getFuncOp())) ==
+               converter.hostAssocTupleValue().getType());
+        addHostAssociations = true;
+      }
+      if (!addHostAssociations &&
+          (callSiteType.getNumResults() != funcOpType.getNumResults() ||
+           callSiteType.getNumInputs() != funcOpType.getNumInputs())) {
+        // Deal with argument number mismatch by making a function pointer so
+        // that function type cast can be inserted. Do not emit a warning here
+        // because this can happen in legal program if the function is not
+        // defined here and it was first passed as an argument without any more
+        // information.
+        funcPointer =
+            builder.create<fir::AddrOfOp>(loc, funcOpType, symbolAttr);
+      } else if (callSiteType.getResults() != funcOpType.getResults()) {
+        // Implicit interface result type mismatch are not standard Fortran, but
+        // some compilers are not complaining about it.  The front end is not
+        // protecting lowering from this currently. Support this with a
+        // discouraging warning.
+        LLVM_DEBUG(mlir::emitWarning(
+            loc, "a return type mismatch is not standard compliant and may "
+                 "lead to undefined behavior."));
+        // Cast the actual function to the current caller implicit type because
+        // that is the behavior we would get if we could not see the definition.
+        funcPointer =
+            builder.create<fir::AddrOfOp>(loc, funcOpType, symbolAttr);
+      } else {
+        funcSymbolAttr = symbolAttr;
+      }
+    }
+
+    mlir::FunctionType funcType =
+        funcPointer ? callSiteType : caller.getFuncOp().getType();
+    llvm::SmallVector<mlir::Value> operands;
+    // First operand of indirect call is the function pointer. Cast it to
+    // required function type for the call to handle procedures that have a
+    // compatible interface in Fortran, but that have different signatures in
+    // FIR.
+    if (funcPointer) {
+      operands.push_back(
+          funcPointer.getType().isa<fir::BoxProcType>()
+              ? builder.create<fir::BoxAddrOp>(loc, funcType, funcPointer)
+              : builder.createConvert(loc, funcType, funcPointer));
+    }
+
+    // Deal with potential mismatches in arguments types. Passing an array to a
+    // scalar argument should for instance be tolerated here.
+    bool callingImplicitInterface = caller.canBeCalledViaImplicitInterface();
+    for (auto [fst, snd] :
+         llvm::zip(caller.getInputs(), funcType.getInputs())) {
+      // When passing arguments to a procedure that can be called an implicit
+      // interface, allow character actual arguments to be passed to dummy
+      // arguments of any type and vice versa
+      mlir::Value cast;
+      auto *context = builder.getContext();
+      if (snd.isa<fir::BoxProcType>() &&
+          fst.getType().isa<mlir::FunctionType>()) {
+        auto funcTy = mlir::FunctionType::get(context, llvm::None, llvm::None);
+        auto boxProcTy = builder.getBoxProcType(funcTy);
+        if (mlir::Value host = argumentHostAssocs(converter, fst)) {
+          cast = builder.create<fir::EmboxProcOp>(
+              loc, boxProcTy, llvm::ArrayRef<mlir::Value>{fst, host});
+        } else {
+          cast = builder.create<fir::EmboxProcOp>(loc, boxProcTy, fst);
+        }
+      } else {
+        cast = builder.convertWithSemantics(loc, snd, fst,
+                                            callingImplicitInterface);
+      }
+      operands.push_back(cast);
+    }
+
+    // Add host associations as necessary.
+    if (addHostAssociations)
+      operands.push_back(converter.hostAssocTupleValue());
+
+    auto call = builder.create<fir::CallOp>(loc, funcType.getResults(),
+                                            funcSymbolAttr, operands);
+
+    if (caller.mustSaveResult())
+      builder.create<fir::SaveResultOp>(
+          loc, call.getResult(0), fir::getBase(allocatedResult.getValue()),
+          arrayResultShape, resultLengths);
+
+    if (allocatedResult) {
+      allocatedResult->match(
+          [&](const fir::MutableBoxValue &box) {
+            if (box.isAllocatable()) {
+              TODO(loc, "allocatedResult for allocatable");
+            }
+          },
+          [](const auto &) {});
+      return *allocatedResult;
+    }
+
+    if (!resultType.hasValue())
+      return mlir::Value{}; // subroutine call
+    // For now, Fortran return values are implemented with a single MLIR
+    // function return value.
+    assert(call.getNumResults() == 1 &&
+           "Expected exactly one result in FUNCTION call");
+    return call.getResult(0);
+  }
+
+  /// Like genExtAddr, but ensure the address returned is a temporary even if \p
+  /// expr is variable inside parentheses.
+  ExtValue genTempExtAddr(const Fortran::lower::SomeExpr &expr) {
+    // In general, genExtAddr might not create a temp for variable inside
+    // 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 genExtValue(expr).match(
+        [&](const fir::CharBoxValue &boxChar) -> ExtValue {
+          TODO(loc, "genTempExtAddr CharBoxValue");
+        },
+        [&](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);
+          return temp;
+        },
+        [&](const fir::BoxValue &x) -> ExtValue {
+          // Derived type scalar that may be polymorphic.
+          assert(!x.hasRank() && x.isDerived());
+          if (x.isDerivedWithLengthParameters())
+            fir::emitFatalError(
+                loc, "making temps for derived type with length parameters");
+          // TODO: polymorphic aspects should be kept but for now the temp
+          // created always has the declared type.
+          mlir::Value var =
+              fir::getBase(fir::factory::readBoxValue(builder, loc, x));
+          auto value = builder.create<fir::LoadOp>(loc, var);
+          mlir::Value temp = builder.createTemporary(loc, value.getType());
+          builder.create<fir::StoreOp>(loc, value, temp);
+          return temp;
+        },
+        [&](const auto &) -> ExtValue {
+          fir::emitFatalError(loc, "expr is not a scalar value");
+        });
+  }
+
+  /// Helper structure to track potential copy-in of non contiguous variable
+  /// argument into a contiguous temp. It is used to deallocate the temp that
+  /// may have been created as well as to the copy-out from the temp to the
+  /// variable after the call.
+  struct CopyOutPair {
+    ExtValue var;
+    ExtValue temp;
+    // Flag to indicate if the argument may have been modified by the
+    // callee, in which case it must be copied-out to the variable.
+    bool argMayBeModifiedByCall;
+    // Optional boolean value that, if present and false, prevents
+    // the copy-out and temp deallocation.
+    llvm::Optional<mlir::Value> restrictCopyAndFreeAtRuntime;
+  };
+  using CopyOutPairs = llvm::SmallVector<CopyOutPair, 4>;
+
+  /// Helper to read any fir::BoxValue into other fir::ExtendedValue categories
+  /// not based on fir.box.
+  /// This will lose any non contiguous stride information and dynamic type and
+  /// should only be called if \p exv is known to be contiguous or if its base
+  /// address will be replaced by a contiguous one. If \p exv is not a
+  /// fir::BoxValue, this is a no-op.
+  ExtValue readIfBoxValue(const ExtValue &exv) {
+    if (const auto *box = exv.getBoxOf<fir::BoxValue>())
+      return fir::factory::readBoxValue(builder, getLoc(), *box);
+    return exv;
+  }
+
+  /// Lower a non-elemental procedure reference.
+  ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
+                              llvm::Optional<mlir::Type> resultType) {
+    mlir::Location loc = getLoc();
+    if (isElementalProcWithArrayArgs(procRef))
+      fir::emitFatalError(loc, "trying to lower elemental procedure with array "
+                               "arguments as normal procedure");
+    if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
+            procRef.proc().GetSpecificIntrinsic())
+      return genIntrinsicRef(procRef, *intrinsic, resultType);
+
+    if (isStatementFunctionCall(procRef))
+      TODO(loc, "Lower statement function call");
+
+    Fortran::lower::CallerInterface caller(procRef, converter);
+    using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
+
+    llvm::SmallVector<fir::MutableBoxValue> mutableModifiedByCall;
+    // List of <var, temp> where temp must be copied into var after the call.
+    CopyOutPairs copyOutPairs;
+
+    mlir::FunctionType callSiteType = caller.genFunctionType();
+
+    // Lower the actual arguments and map the lowered values to the dummy
+    // arguments.
+    for (const Fortran::lower::CallInterface<
+             Fortran::lower::CallerInterface>::PassedEntity &arg :
+         caller.getPassedArguments()) {
+      const auto *actual = arg.entity;
+      mlir::Type argTy = callSiteType.getInput(arg.firArgument);
+      if (!actual) {
+        // Optional dummy argument for which there is no actual argument.
+        caller.placeInput(arg, builder.create<fir::AbsentOp>(loc, argTy));
+        continue;
+      }
+      const auto *expr = actual->UnwrapExpr();
+      if (!expr)
+        TODO(loc, "assumed type actual argument lowering");
+
+      if (arg.passBy == PassBy::Value) {
+        ExtValue argVal = genval(*expr);
+        if (!fir::isUnboxedValue(argVal))
+          fir::emitFatalError(
+              loc, "internal error: passing non trivial value by value");
+        caller.placeInput(arg, fir::getBase(argVal));
+        continue;
+      }
+
+      if (arg.passBy == PassBy::MutableBox) {
+        TODO(loc, "arg passby MutableBox");
+      }
+      const bool actualArgIsVariable = Fortran::evaluate::IsVariable(*expr);
+      if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar) {
+        auto argAddr = [&]() -> ExtValue {
+          ExtValue baseAddr;
+          if (actualArgIsVariable && arg.isOptional()) {
+            if (Fortran::evaluate::IsAllocatableOrPointerObject(
+                    *expr, converter.getFoldingContext())) {
+              TODO(loc, "Allocatable or pointer argument");
+            }
+            if (const Fortran::semantics::Symbol *wholeSymbol =
+                    Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(
+                        *expr))
+              if (Fortran::semantics::IsOptional(*wholeSymbol)) {
+                TODO(loc, "procedureref optional arg");
+              }
+            // Fall through: The actual argument can safely be
+            // copied-in/copied-out without any care if needed.
+          }
+          if (actualArgIsVariable && expr->Rank() > 0) {
+            TODO(loc, "procedureref arrays");
+          }
+          // Actual argument is a non optional/non pointer/non allocatable
+          // scalar.
+          if (actualArgIsVariable)
+            return genExtAddr(*expr);
+          // Actual argument is not a variable. Make sure a variable address is
+          // not passed.
+          return genTempExtAddr(*expr);
+        }();
+        // Scalar and contiguous expressions may be lowered to a fir.box,
+        // either to account for potential polymorphism, or because lowering
+        // did not account for some contiguity hints.
+        // Here, polymorphism does not matter (an entity of the declared type
+        // is passed, not one of the dynamic type), and the expr is known to
+        // be simply contiguous, so it is safe to unbox it and pass the
+        // address without making a copy.
+        argAddr = readIfBoxValue(argAddr);
+
+        if (arg.passBy == PassBy::BaseAddress) {
+          caller.placeInput(arg, fir::getBase(argAddr));
+        } else {
+          TODO(loc, "procedureref PassBy::BoxChar");
+        }
+      } else if (arg.passBy == PassBy::Box) {
+        // Before lowering to an address, handle the allocatable/pointer actual
+        // argument to optional fir.box dummy. It is legal to pass
+        // unallocated/disassociated entity to an optional. In this case, an
+        // absent fir.box must be created instead of a fir.box with a null value
+        // (Fortran 2018 15.5.2.12 point 1).
+        if (arg.isOptional() && Fortran::evaluate::IsAllocatableOrPointerObject(
+                                    *expr, converter.getFoldingContext())) {
+          TODO(loc, "optional allocatable or pointer argument");
+        } else {
+          // Make sure a variable address is only passed if the expression is
+          // actually a variable.
+          mlir::Value box =
+              actualArgIsVariable
+                  ? builder.createBox(loc, genBoxArg(*expr))
+                  : builder.createBox(getLoc(), genTempExtAddr(*expr));
+          caller.placeInput(arg, box);
+        }
+      } else if (arg.passBy == PassBy::AddressAndLength) {
+        ExtValue argRef = genExtAddr(*expr);
+        caller.placeAddressAndLengthInput(arg, fir::getBase(argRef),
+                                          fir::getLen(argRef));
+      } else if (arg.passBy == PassBy::CharProcTuple) {
+        TODO(loc, "procedureref CharProcTuple");
+      } else {
+        TODO(loc, "pass by value in non elemental function call");
+      }
+    }
+
+    ExtValue result = genCallOpAndResult(caller, callSiteType, resultType);
+
+    // // Copy-out temps that were created for non contiguous variable arguments
+    // if
+    // // needed.
+    // for (const auto &copyOutPair : copyOutPairs)
+    //   genCopyOut(copyOutPair);
+
+    return result;
+  }
+
   template <typename A>
   ExtValue genval(const Fortran::evaluate::FunctionRef<A> &funcRef) {
     ExtValue result = genFunctionRef(funcRef);
     if (result.rank() == 0 && fir::isa_ref_type(fir::getBase(result).getType()))
       return genLoad(result);
     return result;
   }
 
   ExtValue genval(const Fortran::evaluate::ProcedureRef &procRef) {
-    TODO(getLoc(), "genval ProcedureRef");
+    llvm::Optional<mlir::Type> resTy;
+    if (procRef.hasAlternateReturns())
+      resTy = builder.getIndexType();
+    return genProcedureRef(procRef, resTy);
   }
 
   /// 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;
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
 
   template <typename A>
   ExtValue genval(const Fortran::evaluate::Expr<A> &x) {
     if (isScalar(x))
       return std::visit([&](const auto &e) { return genval(e); }, x.u);
     TODO(getLoc(), "genval Expr<A> arrays");
   }
 
-  /// Lower a non-elemental procedure reference.
-  // TODO: Handle read allocatable and pointer results.
-  ExtValue genProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
-                           llvm::Optional<mlir::Type> resultType) {
-    ExtValue res = genRawProcedureRef(procRef, resultType);
-    return res;
-  }
-
-  /// Lower a non-elemental procedure reference.
-  ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
-                              llvm::Optional<mlir::Type> resultType) {
-    mlir::Location loc = getLoc();
-    if (isElementalProcWithArrayArgs(procRef))
-      fir::emitFatalError(loc, "trying to lower elemental procedure with array "
-                               "arguments as normal procedure");
-    if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
-            procRef.proc().GetSpecificIntrinsic())
-      return genIntrinsicRef(procRef, *intrinsic, resultType);
-
-    return {};
-  }
-
   /// Helper to detect Transformational function reference.
   template <typename T>
   bool isTransformationalRef(const T &) {
     return false;
   }
   template <typename T>
   bool isTransformationalRef(const Fortran::evaluate::FunctionRef<T> &funcRef) {
     return !funcRef.IsElemental() && funcRef.Rank();
#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
   ExtValue genref(const T<A> &x) {
     return gen(x);
   }
 
 private:
   mlir::Location location;
   Fortran::lower::AbstractConverter &converter;
   fir::FirOpBuilder &builder;
+  Fortran::lower::StatementContext &stmtCtx;
   Fortran::lower::SymMap &symMap;
+  bool useBoxArg = false; // expression lowered as argument
 };
 } // namespace
 
 fir::ExtendedValue Fortran::lower::createSomeExtendedExpression(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
-    const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) {
+    const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
+    Fortran::lower::StatementContext &stmtCtx) {
   LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "expr: ") << '\n');
-  return ScalarExprLowering{loc, converter, symMap}.genval(expr);
+  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) {
+    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}.gen(expr);
+  return ScalarExprLowering{loc, converter, symMap, stmtCtx}.gen(expr);
+}
+
+mlir::Value Fortran::lower::createSubroutineCall(
+    AbstractConverter &converter, const evaluate::ProcedureRef &call,
+    SymMap &symMap, StatementContext &stmtCtx) {
+  mlir::Location loc = converter.getCurrentLocation();
+
+  // Simple subroutine call, with potential alternate return.
+  auto res = Fortran::lower::createSomeExtendedExpression(
+      loc, converter, toEvExpr(call), symMap, stmtCtx);
+  return fir::getBase(res);
 }

flang/lib/Lower/ConvertVariable.cpp

void Fortran::lower::instantiateVariable(AbstractConverter &converter,
   } else if (var.isAlias()) {
     TODO(loc, "instantiateVariable Alias");
   } else if (var.isGlobal()) {
     TODO(loc, "instantiateVariable Global");
   } else {
     instantiateLocal(converter, var, symMap);
   }
 }
+
+void Fortran::lower::mapCallInterfaceSymbols(
+    AbstractConverter &converter, const Fortran::lower::CallerInterface &caller,
+    SymMap &symMap) {
+  const Fortran::semantics::Symbol &result = caller.getResultSymbol();
+  for (Fortran::lower::pft::Variable var :
+       Fortran::lower::pft::buildFuncResultDependencyList(result)) {
+    if (var.isAggregateStore()) {
+      instantiateVariable(converter, var, symMap);
+    } else {
+      const Fortran::semantics::Symbol &sym = var.getSymbol();
+      const auto *hostDetails =
+          sym.detailsIf<Fortran::semantics::HostAssocDetails>();
+      if (hostDetails && !var.isModuleVariable()) {
+        // The callee is an internal procedure `A` whose result properties
+        // depend on host variables. The caller may be the host, or another
+        // internal procedure `B` contained in the same host.  In the first
+        // case, the host symbol is obviously mapped, in the second case, it
+        // must also be mapped because
+        // HostAssociations::internalProcedureBindings that was called when
+        // lowering `B` will have mapped all host symbols of captured variables
+        // to the tuple argument containing the composite of all host associated
+        // variables, whether or not the host symbol is actually referred to in
+        // `B`. Hence it is possible to simply lookup the variable associated to
+        // the host symbol without having to go back to the tuple argument.
+        Fortran::lower::SymbolBox hostValue =
+            symMap.lookupSymbol(hostDetails->symbol());
+        assert(hostValue && "callee host symbol must be mapped on caller side");
+        symMap.addSymbol(sym, hostValue.toExtendedValue());
+        // The SymbolBox associated to the host symbols is complete, skip
+        // instantiateVariable that would try to allocate a new storage.
+        continue;
+      }
+      if (Fortran::semantics::IsDummy(sym) && sym.owner() == result.owner()) {
+        // Get the argument for the dummy argument symbols of the current call.
+        symMap.addSymbol(sym, caller.getArgumentValue(sym));
+        // All the properties of the dummy variable may not come from the actual
+        // argument, let instantiateVariable handle this.
+      }
+      // If this is neither a host associated or dummy symbol, it must be a
+      // module or common block variable to satisfy specification expression
+      // requirements in 10.1.11, instantiateVariable will get its address and
+      // properties.
+      instantiateVariable(converter, var, symMap);
+    }
+  }
+}

flang/lib/Lower/OpenACC.cpp

 //===-- OpenACC.cpp -- OpenACC directive lowering -------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/OpenACC.h"
 #include "flang/Common/idioms.h"
 #include "flang/Lower/Bridge.h"
 #include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/OpenACC/OpenACC.h"
 #include "llvm/Frontend/OpenACC/ACC.h.inc"
 
static Op createSimpleOp(fir::FirOpBuilder &builder, mlir::Location loc,
   op->setAttr(Op::getOperandSegmentSizeAttr(),
               builder.getI32VectorAttr(operandSegments));
   return op;
 }
 
 static void genACC(Fortran::lower::AbstractConverter &converter,
                    Fortran::lower::pft::Evaluation &eval,
                    const Fortran::parser::OpenACCLoopConstruct &loopConstruct) {
-
+  Fortran::lower::StatementContext stmtCtx;
   const auto &beginLoopDirective =
       std::get<Fortran::parser::AccBeginLoopDirective>(loopConstruct.t);
   const auto &loopDirective =
       std::get<Fortran::parser::AccLoopDirective>(beginLoopDirective.t);
 
   if (loopDirective.v == llvm::acc::ACCD_loop) {
     auto &firOpBuilder = converter.getFirOpBuilder();
     auto currentLocation = converter.getCurrentLocation();
for (const auto &clause : accClauseList.v) {
       if (const auto *gangClause =
               std::get_if<Fortran::parser::AccClause::Gang>(&clause.u)) {
         if (gangClause->v) {
           const Fortran::parser::AccGangArgument &x = *gangClause->v;
           if (const auto &gangNumValue =
                   std::get<std::optional<Fortran::parser::ScalarIntExpr>>(
                       x.t)) {
             gangNum = fir::getBase(converter.genExprValue(
-                *Fortran::semantics::GetExpr(gangNumValue.value())));
+                *Fortran::semantics::GetExpr(gangNumValue.value()), stmtCtx));
           }
           if (const auto &gangStaticValue =
                   std::get<std::optional<Fortran::parser::AccSizeExpr>>(x.t)) {
             const auto &expr =
                 std::get<std::optional<Fortran::parser::ScalarIntExpr>>(
                     gangStaticValue.value().t);
             if (expr) {
-              gangStatic = fir::getBase(
-                  converter.genExprValue(*Fortran::semantics::GetExpr(*expr)));
+              gangStatic = fir::getBase(converter.genExprValue(
+                  *Fortran::semantics::GetExpr(*expr), stmtCtx));
             } else {
               // * was passed as value and will be represented as a -1 constant
               // integer.
               gangStatic = firOpBuilder.createIntegerConstant(
                   currentLocation, firOpBuilder.getIntegerType(32),
                   /* STAR */ -1);
             }
           }
         }
         executionMapping |= mlir::acc::OpenACCExecMapping::GANG;
       } else if (const auto *workerClause =
                      std::get_if<Fortran::parser::AccClause::Worker>(
                          &clause.u)) {
         if (workerClause->v) {
           workerNum = fir::getBase(converter.genExprValue(
-              *Fortran::semantics::GetExpr(*workerClause->v)));
+              *Fortran::semantics::GetExpr(*workerClause->v), stmtCtx));
         }
         executionMapping |= mlir::acc::OpenACCExecMapping::WORKER;
       } else if (const auto *vectorClause =
                      std::get_if<Fortran::parser::AccClause::Vector>(
                          &clause.u)) {
         if (vectorClause->v) {
           vectorLength = fir::getBase(converter.genExprValue(
-              *Fortran::semantics::GetExpr(*vectorClause->v)));
+              *Fortran::semantics::GetExpr(*vectorClause->v), stmtCtx));
         }
         executionMapping |= mlir::acc::OpenACCExecMapping::VECTOR;
       } else if (const auto *tileClause =
                      std::get_if<Fortran::parser::AccClause::Tile>(&clause.u)) {
         const Fortran::parser::AccTileExprList &accTileExprList = tileClause->v;
         for (const auto &accTileExpr : accTileExprList.v) {
           const auto &expr =
               std::get<std::optional<Fortran::parser::ScalarIntConstantExpr>>(
                   accTileExpr.t);
           if (expr) {
-            tileOperands.push_back(fir::getBase(
-                converter.genExprValue(*Fortran::semantics::GetExpr(*expr))));
+            tileOperands.push_back(fir::getBase(converter.genExprValue(
+                *Fortran::semantics::GetExpr(*expr), stmtCtx)));
           } else {
             // * was passed as value and will be represented as a -1 constant
             // integer.
             mlir::Value tileStar = firOpBuilder.createIntegerConstant(
                 currentLocation, firOpBuilder.getIntegerType(32),
                 /* STAR */ -1);
             tileOperands.push_back(tileStar);
           }
genACCParallelOp(Fortran::lower::AbstractConverter &converter,
   // no value as well. When there is no value, the op has an attribute to
   // represent the clause.
   bool addAsyncAttr = false;
   bool addWaitAttr = false;
   bool addSelfAttr = false;
 
   auto &firOpBuilder = converter.getFirOpBuilder();
   auto currentLocation = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
 
   // Lower clauses values mapped to operands.
   // Keep track of each group of operands separatly as clauses can appear
   // more than once.
   for (const auto &clause : accClauseList.v) {
     if (const auto *asyncClause =
             std::get_if<Fortran::parser::AccClause::Async>(&clause.u)) {
       const auto &asyncClauseValue = asyncClause->v;
       if (asyncClauseValue) { // async has a value.
         async = fir::getBase(converter.genExprValue(
-            *Fortran::semantics::GetExpr(*asyncClauseValue)));
+            *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx));
       } else {
         addAsyncAttr = true;
       }
     } else if (const auto *waitClause =
                    std::get_if<Fortran::parser::AccClause::Wait>(&clause.u)) {
       const auto &waitClauseValue = waitClause->v;
       if (waitClauseValue) { // wait has a value.
         const Fortran::parser::AccWaitArgument &waitArg = *waitClauseValue;
         const std::list<Fortran::parser::ScalarIntExpr> &waitList =
             std::get<std::list<Fortran::parser::ScalarIntExpr>>(waitArg.t);
         for (const Fortran::parser::ScalarIntExpr &value : waitList) {
-          Value v = fir::getBase(
-              converter.genExprValue(*Fortran::semantics::GetExpr(value)));
+          Value v = fir::getBase(converter.genExprValue(
+              *Fortran::semantics::GetExpr(value), stmtCtx));
           waitOperands.push_back(v);
         }
       } else {
         addWaitAttr = true;
       }
     } else if (const auto *numGangsClause =
                    std::get_if<Fortran::parser::AccClause::NumGangs>(
                        &clause.u)) {
       numGangs = fir::getBase(converter.genExprValue(
-          *Fortran::semantics::GetExpr(numGangsClause->v)));
+          *Fortran::semantics::GetExpr(numGangsClause->v), stmtCtx));
     } else if (const auto *numWorkersClause =
                    std::get_if<Fortran::parser::AccClause::NumWorkers>(
                        &clause.u)) {
       numWorkers = fir::getBase(converter.genExprValue(
-          *Fortran::semantics::GetExpr(numWorkersClause->v)));
+          *Fortran::semantics::GetExpr(numWorkersClause->v), stmtCtx));
     } else if (const auto *vectorLengthClause =
                    std::get_if<Fortran::parser::AccClause::VectorLength>(
                        &clause.u)) {
       vectorLength = fir::getBase(converter.genExprValue(
-          *Fortran::semantics::GetExpr(vectorLengthClause->v)));
+          *Fortran::semantics::GetExpr(vectorLengthClause->v), stmtCtx));
     } else if (const auto *ifClause =
                    std::get_if<Fortran::parser::AccClause::If>(&clause.u)) {
-      Value cond = fir::getBase(
-          converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v)));
+      Value cond = fir::getBase(converter.genExprValue(
+          *Fortran::semantics::GetExpr(ifClause->v), stmtCtx));
       ifCond = firOpBuilder.createConvert(currentLocation,
                                           firOpBuilder.getI1Type(), cond);
     } else if (const auto *selfClause =
                    std::get_if<Fortran::parser::AccClause::Self>(&clause.u)) {
       const Fortran::parser::AccSelfClause &accSelfClause = selfClause->v;
       if (const auto *optCondition =
               std::get_if<std::optional<Fortran::parser::ScalarLogicalExpr>>(
                   &accSelfClause.u)) {
         if (*optCondition) {
           Value cond = fir::getBase(converter.genExprValue(
-              *Fortran::semantics::GetExpr(*optCondition)));
+              *Fortran::semantics::GetExpr(*optCondition), stmtCtx));
           selfCond = firOpBuilder.createConvert(currentLocation,
                                                 firOpBuilder.getI1Type(), cond);
         } else {
           addSelfAttr = true;
         }
       }
     } else if (const auto *copyClause =
                    std::get_if<Fortran::parser::AccClause::Copy>(&clause.u)) {
static void genACCDataOp(Fortran::lower::AbstractConverter &converter,
                          const Fortran::parser::AccClauseList &accClauseList) {
   mlir::Value ifCond;
   SmallVector<Value, 2> copyOperands, copyinOperands, copyinReadonlyOperands,
       copyoutOperands, copyoutZeroOperands, createOperands, createZeroOperands,
       noCreateOperands, presentOperands, deviceptrOperands, attachOperands;
 
   auto &firOpBuilder = converter.getFirOpBuilder();
   auto currentLocation = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
 
   // Lower clauses values mapped to operands.
   // Keep track of each group of operands separatly as clauses can appear
   // more than once.
   for (const auto &clause : accClauseList.v) {
     if (const auto *ifClause =
             std::get_if<Fortran::parser::AccClause::If>(&clause.u)) {
-      Value cond = fir::getBase(
-          converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v)));
+      Value cond = fir::getBase(converter.genExprValue(
+          *Fortran::semantics::GetExpr(ifClause->v), stmtCtx));
       ifCond = firOpBuilder.createConvert(currentLocation,
                                           firOpBuilder.getI1Type(), cond);
     } else if (const auto *copyClause =
                    std::get_if<Fortran::parser::AccClause::Copy>(&clause.u)) {
       genObjectList(copyClause->v, converter, copyOperands);
     } else if (const auto *copyinClause =
                    std::get_if<Fortran::parser::AccClause::Copyin>(&clause.u)) {
       genObjectListWithModifier<Fortran::parser::AccClause::Copyin>(
genACCEnterDataOp(Fortran::lower::AbstractConverter &converter,
   // Async, wait and self clause have optional values but can be present with
   // no value as well. When there is no value, the op has an attribute to
   // represent the clause.
   bool addAsyncAttr = false;
   bool addWaitAttr = false;
 
   auto &firOpBuilder = converter.getFirOpBuilder();
   auto currentLocation = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
 
   // Lower clauses values mapped to operands.
   // Keep track of each group of operands separatly as clauses can appear
   // more than once.
   for (const auto &clause : accClauseList.v) {
     if (const auto *ifClause =
             std::get_if<Fortran::parser::AccClause::If>(&clause.u)) {
-      mlir::Value cond = fir::getBase(
-          converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v)));
+      mlir::Value cond = fir::getBase(converter.genExprValue(
+          *Fortran::semantics::GetExpr(ifClause->v), stmtCtx));
       ifCond = firOpBuilder.createConvert(currentLocation,
                                           firOpBuilder.getI1Type(), cond);
     } else if (const auto *asyncClause =
                    std::get_if<Fortran::parser::AccClause::Async>(&clause.u)) {
       const auto &asyncClauseValue = asyncClause->v;
       if (asyncClauseValue) { // async has a value.
         async = fir::getBase(converter.genExprValue(
-            *Fortran::semantics::GetExpr(*asyncClauseValue)));
+            *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx));
       } else {
         addAsyncAttr = true;
       }
     } else if (const auto *waitClause =
                    std::get_if<Fortran::parser::AccClause::Wait>(&clause.u)) {
       const auto &waitClauseValue = waitClause->v;
       if (waitClauseValue) { // wait has a value.
         const Fortran::parser::AccWaitArgument &waitArg = *waitClauseValue;
         const std::list<Fortran::parser::ScalarIntExpr> &waitList =
             std::get<std::list<Fortran::parser::ScalarIntExpr>>(waitArg.t);
         for (const Fortran::parser::ScalarIntExpr &value : waitList) {
-          mlir::Value v = fir::getBase(
-              converter.genExprValue(*Fortran::semantics::GetExpr(value)));
+          mlir::Value v = fir::getBase(converter.genExprValue(
+              *Fortran::semantics::GetExpr(value), stmtCtx));
           waitOperands.push_back(v);
         }
 
         const std::optional<Fortran::parser::ScalarIntExpr> &waitDevnumValue =
             std::get<std::optional<Fortran::parser::ScalarIntExpr>>(waitArg.t);
         if (waitDevnumValue)
           waitDevnum = fir::getBase(converter.genExprValue(
-              *Fortran::semantics::GetExpr(*waitDevnumValue)));
+              *Fortran::semantics::GetExpr(*waitDevnumValue), stmtCtx));
       } else {
         addWaitAttr = true;
       }
     } else if (const auto *copyinClause =
                    std::get_if<Fortran::parser::AccClause::Copyin>(&clause.u)) {
       const Fortran::parser::AccObjectListWithModifier &listWithModifier =
           copyinClause->v;
       const Fortran::parser::AccObjectList &accObjectList =
genACCExitDataOp(Fortran::lower::AbstractConverter &converter,
   // no value as well. When there is no value, the op has an attribute to
   // represent the clause.
   bool addAsyncAttr = false;
   bool addWaitAttr = false;
   bool addFinalizeAttr = false;
 
   auto &firOpBuilder = converter.getFirOpBuilder();
   auto currentLocation = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
 
   // Lower clauses values mapped to operands.
   // Keep track of each group of operands separatly as clauses can appear
   // more than once.
   for (const auto &clause : accClauseList.v) {
     if (const auto *ifClause =
             std::get_if<Fortran::parser::AccClause::If>(&clause.u)) {
-      Value cond = fir::getBase(
-          converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v)));
+      Value cond = fir::getBase(converter.genExprValue(
+          *Fortran::semantics::GetExpr(ifClause->v), stmtCtx));
       ifCond = firOpBuilder.createConvert(currentLocation,
                                           firOpBuilder.getI1Type(), cond);
     } else if (const auto *asyncClause =
                    std::get_if<Fortran::parser::AccClause::Async>(&clause.u)) {
       const auto &asyncClauseValue = asyncClause->v;
       if (asyncClauseValue) { // async has a value.
         async = fir::getBase(converter.genExprValue(
-            *Fortran::semantics::GetExpr(*asyncClauseValue)));
+            *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx));
       } else {
         addAsyncAttr = true;
       }
     } else if (const auto *waitClause =
                    std::get_if<Fortran::parser::AccClause::Wait>(&clause.u)) {
       const auto &waitClauseValue = waitClause->v;
       if (waitClauseValue) { // wait has a value.
         const Fortran::parser::AccWaitArgument &waitArg = *waitClauseValue;
         const std::list<Fortran::parser::ScalarIntExpr> &waitList =
             std::get<std::list<Fortran::parser::ScalarIntExpr>>(waitArg.t);
         for (const Fortran::parser::ScalarIntExpr &value : waitList) {
-          Value v = fir::getBase(
-              converter.genExprValue(*Fortran::semantics::GetExpr(value)));
+          Value v = fir::getBase(converter.genExprValue(
+              *Fortran::semantics::GetExpr(value), stmtCtx));
           waitOperands.push_back(v);
         }
 
         const std::optional<Fortran::parser::ScalarIntExpr> &waitDevnumValue =
             std::get<std::optional<Fortran::parser::ScalarIntExpr>>(waitArg.t);
         if (waitDevnumValue)
           waitDevnum = fir::getBase(converter.genExprValue(
-              *Fortran::semantics::GetExpr(*waitDevnumValue)));
+              *Fortran::semantics::GetExpr(*waitDevnumValue), stmtCtx));
       } else {
         addWaitAttr = true;
       }
     } else if (const auto *copyoutClause =
                    std::get_if<Fortran::parser::AccClause::Copyout>(
                        &clause.u)) {
       const Fortran::parser::AccObjectListWithModifier &listWithModifier =
           copyoutClause->v;

 static void
 genACCInitShutdownOp(Fortran::lower::AbstractConverter &converter,
                      const Fortran::parser::AccClauseList &accClauseList) {
   mlir::Value ifCond, deviceNum;
   SmallVector<Value, 2> deviceTypeOperands;
 
   auto &firOpBuilder = converter.getFirOpBuilder();
   auto currentLocation = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
 
   // Lower clauses values mapped to operands.
   // Keep track of each group of operands separatly as clauses can appear
   // more than once.
   for (const auto &clause : accClauseList.v) {
     if (const auto *ifClause =
             std::get_if<Fortran::parser::AccClause::If>(&clause.u)) {
-      mlir::Value cond = fir::getBase(
-          converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v)));
+      mlir::Value cond = fir::getBase(converter.genExprValue(
+          *Fortran::semantics::GetExpr(ifClause->v), stmtCtx));
       ifCond = firOpBuilder.createConvert(currentLocation,
                                           firOpBuilder.getI1Type(), cond);
     } else if (const auto *deviceNumClause =
                    std::get_if<Fortran::parser::AccClause::DeviceNum>(
                        &clause.u)) {
       deviceNum = fir::getBase(converter.genExprValue(
-          *Fortran::semantics::GetExpr(deviceNumClause->v)));
+          *Fortran::semantics::GetExpr(deviceNumClause->v), stmtCtx));
     } else if (const auto *deviceTypeClause =
                    std::get_if<Fortran::parser::AccClause::DeviceType>(
                        &clause.u)) {
 
       const auto &deviceTypeValue = deviceTypeClause->v;
       if (deviceTypeValue) {
         for (const auto &scalarIntExpr : *deviceTypeValue) {
           mlir::Value expr = fir::getBase(converter.genExprValue(
-              *Fortran::semantics::GetExpr(scalarIntExpr)));
+              *Fortran::semantics::GetExpr(scalarIntExpr), stmtCtx));
           deviceTypeOperands.push_back(expr);
         }
       } else {
         // * was passed as value and will be represented as a -1 constant
         // integer.
         mlir::Value star = firOpBuilder.createIntegerConstant(
             currentLocation, firOpBuilder.getIntegerType(32), /* STAR */ -1);
         deviceTypeOperands.push_back(star);
genACCUpdateOp(Fortran::lower::AbstractConverter &converter,
   // no value as well. When there is no value, the op has an attribute to
   // represent the clause.
   bool addAsyncAttr = false;
   bool addWaitAttr = false;
   bool addIfPresentAttr = false;
 
   auto &firOpBuilder = converter.getFirOpBuilder();
   auto currentLocation = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
 
   // Lower clauses values mapped to operands.
   // Keep track of each group of operands separatly as clauses can appear
   // more than once.
   for (const auto &clause : accClauseList.v) {
     if (const auto *ifClause =
             std::get_if<Fortran::parser::AccClause::If>(&clause.u)) {
-      mlir::Value cond = fir::getBase(
-          converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v)));
+      mlir::Value cond = fir::getBase(converter.genExprValue(
+          *Fortran::semantics::GetExpr(ifClause->v), stmtCtx));
       ifCond = firOpBuilder.createConvert(currentLocation,
                                           firOpBuilder.getI1Type(), cond);
     } else if (const auto *asyncClause =
                    std::get_if<Fortran::parser::AccClause::Async>(&clause.u)) {
       const auto &asyncClauseValue = asyncClause->v;
       if (asyncClauseValue) { // async has a value.
         async = fir::getBase(converter.genExprValue(
-            *Fortran::semantics::GetExpr(*asyncClauseValue)));
+            *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx));
       } else {
         addAsyncAttr = true;
       }
     } else if (const auto *waitClause =
                    std::get_if<Fortran::parser::AccClause::Wait>(&clause.u)) {
       const auto &waitClauseValue = waitClause->v;
       if (waitClauseValue) { // wait has a value.
         const Fortran::parser::AccWaitArgument &waitArg = *waitClauseValue;
         const std::list<Fortran::parser::ScalarIntExpr> &waitList =
             std::get<std::list<Fortran::parser::ScalarIntExpr>>(waitArg.t);
         for (const Fortran::parser::ScalarIntExpr &value : waitList) {
-          mlir::Value v = fir::getBase(
-              converter.genExprValue(*Fortran::semantics::GetExpr(value)));
+          mlir::Value v = fir::getBase(converter.genExprValue(
+              *Fortran::semantics::GetExpr(value), stmtCtx));
           waitOperands.push_back(v);
         }
 
         const std::optional<Fortran::parser::ScalarIntExpr> &waitDevnumValue =
             std::get<std::optional<Fortran::parser::ScalarIntExpr>>(waitArg.t);
         if (waitDevnumValue)
           waitDevnum = fir::getBase(converter.genExprValue(
-              *Fortran::semantics::GetExpr(*waitDevnumValue)));
+              *Fortran::semantics::GetExpr(*waitDevnumValue), stmtCtx));
       } else {
         addWaitAttr = true;
       }
     } else if (const auto *deviceTypeClause =
                    std::get_if<Fortran::parser::AccClause::DeviceType>(
                        &clause.u)) {
 
       const auto &deviceTypeValue = deviceTypeClause->v;
       if (deviceTypeValue) {
         for (const auto &scalarIntExpr : *deviceTypeValue) {
           mlir::Value expr = fir::getBase(converter.genExprValue(
-              *Fortran::semantics::GetExpr(scalarIntExpr)));
+              *Fortran::semantics::GetExpr(scalarIntExpr), stmtCtx));
           deviceTypeOperands.push_back(expr);
         }
       } else {
         // * was passed as value and will be represented as a -1 constant
         // integer.
         mlir::Value star = firOpBuilder.createIntegerConstant(
             currentLocation, firOpBuilder.getIntegerType(32), /* STAR */ -1);
         deviceTypeOperands.push_back(star);
static void genACC(Fortran::lower::AbstractConverter &converter,
 
   // Async clause have optional values but can be present with
   // no value as well. When there is no value, the op has an attribute to
   // represent the clause.
   bool addAsyncAttr = false;
 
   auto &firOpBuilder = converter.getFirOpBuilder();
   auto currentLocation = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
 
   if (waitArgument) { // wait has a value.
     const Fortran::parser::AccWaitArgument &waitArg = *waitArgument;
     const std::list<Fortran::parser::ScalarIntExpr> &waitList =
         std::get<std::list<Fortran::parser::ScalarIntExpr>>(waitArg.t);
     for (const Fortran::parser::ScalarIntExpr &value : waitList) {
       mlir::Value v = fir::getBase(
-          converter.genExprValue(*Fortran::semantics::GetExpr(value)));
+          converter.genExprValue(*Fortran::semantics::GetExpr(value), stmtCtx));
       waitOperands.push_back(v);
     }
 
     const std::optional<Fortran::parser::ScalarIntExpr> &waitDevnumValue =
         std::get<std::optional<Fortran::parser::ScalarIntExpr>>(waitArg.t);
     if (waitDevnumValue)
       waitDevnum = fir::getBase(converter.genExprValue(
-          *Fortran::semantics::GetExpr(*waitDevnumValue)));
+          *Fortran::semantics::GetExpr(*waitDevnumValue), stmtCtx));
   }
 
   // Lower clauses values mapped to operands.
   // Keep track of each group of operands separatly as clauses can appear
   // more than once.
   for (const auto &clause : accClauseList.v) {
     if (const auto *ifClause =
             std::get_if<Fortran::parser::AccClause::If>(&clause.u)) {
-      mlir::Value cond = fir::getBase(
-          converter.genExprValue(*Fortran::semantics::GetExpr(ifClause->v)));
+      mlir::Value cond = fir::getBase(converter.genExprValue(
+          *Fortran::semantics::GetExpr(ifClause->v), stmtCtx));
       ifCond = firOpBuilder.createConvert(currentLocation,
                                           firOpBuilder.getI1Type(), cond);
     } else if (const auto *asyncClause =
                    std::get_if<Fortran::parser::AccClause::Async>(&clause.u)) {
       const auto &asyncClauseValue = asyncClause->v;
       if (asyncClauseValue) { // async has a value.
         async = fir::getBase(converter.genExprValue(
-            *Fortran::semantics::GetExpr(*asyncClauseValue)));
+            *Fortran::semantics::GetExpr(*asyncClauseValue), stmtCtx));
       } else {
         addAsyncAttr = true;
       }
     }
   }
 
   // Prepare the operand segement size attribute and the operands value range.
   SmallVector<mlir::Value, 8> operands;

flang/lib/Lower/OpenMP.cpp

 //===-- OpenMP.cpp -- Open MP directive lowering --------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/OpenMP.h"
 #include "flang/Common/idioms.h"
 #include "flang/Lower/Bridge.h"
 #include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/OpenMP/OpenMPDialect.h"
 #include "llvm/Frontend/OpenMP/OMPConstants.h"
 
genOMP(Fortran::lower::AbstractConverter &converter,
        const Fortran::parser::OpenMPBlockConstruct &blockConstruct) {
   const auto &beginBlockDirective =
       std::get<Fortran::parser::OmpBeginBlockDirective>(blockConstruct.t);
   const auto &blockDirective =
       std::get<Fortran::parser::OmpBlockDirective>(beginBlockDirective.t);
 
   auto &firOpBuilder = converter.getFirOpBuilder();
   auto currentLocation = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
   llvm::ArrayRef<mlir::Type> argTy;
   if (blockDirective.v == llvm::omp::OMPD_parallel) {
 
     mlir::Value ifClauseOperand, numThreadsClauseOperand;
     Attribute procBindClauseOperand;
 
     const auto &parallelOpClauseList =
         std::get<Fortran::parser::OmpClauseList>(beginBlockDirective.t);
     for (const auto &clause : parallelOpClauseList.v) {
       if (const auto &ifClause =
               std::get_if<Fortran::parser::OmpClause::If>(&clause.u)) {
         auto &expr =
             std::get<Fortran::parser::ScalarLogicalExpr>(ifClause->v.t);
-        ifClauseOperand = fir::getBase(
-            converter.genExprValue(*Fortran::semantics::GetExpr(expr)));
+        ifClauseOperand = fir::getBase(converter.genExprValue(
+            *Fortran::semantics::GetExpr(expr), stmtCtx));
       } else if (const auto &numThreadsClause =
                      std::get_if<Fortran::parser::OmpClause::NumThreads>(
                          &clause.u)) {
         // OMPIRBuilder expects `NUM_THREAD` clause as a `Value`.
         numThreadsClauseOperand = fir::getBase(converter.genExprValue(
-            *Fortran::semantics::GetExpr(numThreadsClause->v)));
+            *Fortran::semantics::GetExpr(numThreadsClause->v), stmtCtx));
       }
       // TODO: Handle private, firstprivate, shared and copyin
     }
     // Create and insert the operation.
     auto parallelOp = firOpBuilder.create<mlir::omp::ParallelOp>(
         currentLocation, argTy, ifClauseOperand, numThreadsClauseOperand,
         ValueRange(), ValueRange(),
         procBindClauseOperand.dyn_cast_or_null<omp::ClauseProcBindKindAttr>());

flang/lib/Lower/Runtime.cpp

 //===-- Runtime.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 "flang/Lower/Runtime.h"
 #include "flang/Lower/Bridge.h"
+#include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Runtime/stop.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/Debug.h"
 

 // Misc. Fortran statements that lower to runtime calls
 //===----------------------------------------------------------------------===//
 
 void Fortran::lower::genStopStatement(
     Fortran::lower::AbstractConverter &converter,
     const Fortran::parser::StopStmt &stmt) {
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   mlir::Location loc = converter.getCurrentLocation();
+  Fortran::lower::StatementContext stmtCtx;
   llvm::SmallVector<mlir::Value> operands;
   mlir::FuncOp callee;
   mlir::FunctionType calleeType;
   // First operand is stop code (zero if absent)
   if (const auto &code =
           std::get<std::optional<Fortran::parser::StopCode>>(stmt.t)) {
-    auto expr = converter.genExprValue(*Fortran::semantics::GetExpr(*code));
+    auto expr =
+        converter.genExprValue(*Fortran::semantics::GetExpr(*code), stmtCtx);
     LLVM_DEBUG(llvm::dbgs() << "stop expression: "; expr.dump();
                llvm::dbgs() << '\n');
     expr.match(
         [&](const fir::CharBoxValue &x) {
           callee = fir::runtime::getRuntimeFunc<mkRTKey(StopStatementText)>(
               loc, builder);
           calleeType = callee.getType();
           // Creates a pair of operands for the CHARACTER and its LEN.
void Fortran::lower::genStopStatement(
   operands.push_back(builder.createIntegerConstant(
       loc, calleeType.getInput(operands.size()), isError));
 
   // Third operand indicates QUIET (default to false).
   if (const auto &quiet =
           std::get<std::optional<Fortran::parser::ScalarLogicalExpr>>(stmt.t)) {
     const SomeExpr *expr = Fortran::semantics::GetExpr(*quiet);
     assert(expr && "failed getting typed expression");
-    mlir::Value q = fir::getBase(converter.genExprValue(*expr));
+    mlir::Value q = fir::getBase(converter.genExprValue(*expr, stmtCtx));
     operands.push_back(
         builder.createConvert(loc, calleeType.getInput(operands.size()), q));
   } else {
     operands.push_back(builder.createIntegerConstant(
         loc, calleeType.getInput(operands.size()), 0));
   }
 
   builder.create<fir::CallOp>(loc, callee, operands);

flang/lib/Optimizer/Builder/FIRBuilder.cpp

mlir::FuncOp fir::FirOpBuilder::createFunction(mlir::Location loc,
   return fir::createFuncOp(loc, module, name, ty);
 }
 
 mlir::FuncOp fir::FirOpBuilder::getNamedFunction(mlir::ModuleOp modOp,
                                                  llvm::StringRef name) {
   return modOp.lookupSymbol<mlir::FuncOp>(name);
 }
 
+mlir::FuncOp fir::FirOpBuilder::getNamedFunction(mlir::ModuleOp modOp,
+                                                 mlir::SymbolRefAttr symbol) {
+  return modOp.lookupSymbol<mlir::FuncOp>(symbol);
+}
+
 fir::GlobalOp fir::FirOpBuilder::getNamedGlobal(mlir::ModuleOp modOp,
                                                 llvm::StringRef name) {
   return modOp.lookupSymbol<fir::GlobalOp>(name);
 }
 
 mlir::Type fir::FirOpBuilder::getRefType(mlir::Type eleTy) {
   assert(!eleTy.isa<fir::ReferenceType>() && "cannot be a reference type");
   return fir::ReferenceType::get(eleTy);
fir::GlobalOp fir::FirOpBuilder::createGlobal(
   region.push_back(new mlir::Block);
   auto &block = glob.getRegion().back();
   setInsertionPointToStart(&block);
   bodyBuilder(*this);
   restoreInsertionPoint(insertPt);
   return glob;
 }
 
-mlir::Value fir::FirOpBuilder::convertWithSemantics(mlir::Location loc,
-                                                    mlir::Type toTy,
-                                                    mlir::Value val) {
+mlir::Value
+fir::FirOpBuilder::convertWithSemantics(mlir::Location loc, mlir::Type toTy,
+                                        mlir::Value val,
+                                        bool allowCharacterConversion) {
   assert(toTy && "store location must be typed");
   auto fromTy = val.getType();
   if (fromTy == toTy)
     return val;
   fir::factory::Complex helper{*this, loc};
   if ((fir::isa_real(fromTy) || fir::isa_integer(fromTy)) &&
       fir::isa_complex(toTy)) {
     // imaginary part is zero
     auto eleTy = helper.getComplexPartType(toTy);
     auto cast = createConvert(loc, eleTy, val);
     llvm::APFloat zero{
         kindMap.getFloatSemantics(toTy.cast<fir::ComplexType>().getFKind()), 0};
     auto imag = createRealConstant(loc, eleTy, zero);
     return helper.createComplex(toTy, cast, imag);
   }
   if (fir::isa_complex(fromTy) &&
       (fir::isa_integer(toTy) || fir::isa_real(toTy))) {
     // drop the imaginary part
     auto rp = helper.extractComplexPart(val, /*isImagPart=*/false);
     return createConvert(loc, toTy, rp);
   }
+  if (allowCharacterConversion) {
+    if (fromTy.isa<fir::BoxCharType>()) {
+      // Extract the address of the character string and pass it
+      fir::factory::CharacterExprHelper charHelper{*this, loc};
+      std::pair<mlir::Value, mlir::Value> unboxchar =
+          charHelper.createUnboxChar(val);
+      return createConvert(loc, toTy, unboxchar.first);
+    }
+    if (auto boxType = toTy.dyn_cast<fir::BoxCharType>()) {
+      // Extract the address of the actual argument and create a boxed
+      // character value with an undefined length
+      // TODO: We should really calculate the total size of the actual
+      // argument in characters and use it as the length of the string
+      auto refType = getRefType(boxType.getEleTy());
+      mlir::Value charBase = createConvert(loc, refType, val);
+      mlir::Value unknownLen = create<fir::UndefOp>(loc, getIndexType());
+      fir::factory::CharacterExprHelper charHelper{*this, loc};
+      return charHelper.createEmboxChar(charBase, unknownLen);
+    }
+  }
+  if (fir::isa_ref_type(toTy) && fir::isa_box_type(fromTy)) {
+    // Call is expecting a raw data pointer, not a box. Get the data pointer out
+    // of the box and pass that.
+    assert((fir::unwrapRefType(toTy) ==
+                fir::unwrapRefType(fir::unwrapPassByRefType(fromTy)) &&
+            "element types expected to match"));
+    return create<fir::BoxAddrOp>(loc, toTy, val);
+  }
+
   return createConvert(loc, toTy, val);
 }
 
 mlir::Value fir::FirOpBuilder::createConvert(mlir::Location loc,
                                              mlir::Type toTy, mlir::Value val) {
   if (val.getType() != toTy) {
     assert(!fir::isa_derived(toTy));
     return create<fir::ConvertOp>(loc, toTy, val);
return box.match(
       },
       [&](const fir::MutableBoxValue &x) -> llvm::SmallVector<mlir::Value> {
         auto load = fir::factory::genMutableBoxRead(builder, loc, x);
         return fir::factory::getExtents(builder, loc, load);
       },
       [&](const auto &) -> llvm::SmallVector<mlir::Value> { return {}; });
 }
 
+fir::ExtendedValue fir::factory::readBoxValue(fir::FirOpBuilder &builder,
+                                              mlir::Location loc,
+                                              const fir::BoxValue &box) {
+  assert(!box.isUnlimitedPolymorphic() && !box.hasAssumedRank() &&
+         "cannot read unlimited polymorphic or assumed rank fir.box");
+  auto addr =
+      builder.create<fir::BoxAddrOp>(loc, box.getMemTy(), box.getAddr());
+  if (box.isCharacter()) {
+    auto len = fir::factory::readCharLen(builder, loc, box);
+    if (box.rank() == 0)
+      return fir::CharBoxValue(addr, len);
+    return fir::CharArrayBoxValue(addr, len,
+                                  fir::factory::readExtents(builder, loc, box),
+                                  box.getLBounds());
+  }
+  if (box.isDerivedWithLengthParameters())
+    TODO(loc, "read fir.box with length parameters");
+  if (box.rank() == 0)
+    return addr;
+  return fir::ArrayBoxValue(addr, fir::factory::readExtents(builder, loc, box),
+                            box.getLBounds());
+}
+
 std::string fir::factory::uniqueCGIdent(llvm::StringRef prefix,
                                         llvm::StringRef name) {
   // For "long" identifiers use a hash value
   if (name.size() > nameLengthHashSize) {
     llvm::MD5 hash;
     hash.update(name);
     llvm::MD5::MD5Result result;
     hash.final(result);

flang/lib/Optimizer/Dialect/FIROps.cpp

if (auto addressOfOp = mlir::dyn_cast<fir::AddrOfOp>(definingOp)) {
           return globalOp->hasAttr(attributeName);
     }
   }
   // TODO: Construct associated entities attributes. Decide where the fir
   // attributes must be placed/looked for in this case.
   return false;
 }
 
+bool fir::anyFuncArgsHaveAttr(mlir::FuncOp func, llvm::StringRef attr) {
+  for (unsigned i = 0, end = func.getNumArguments(); i < end; ++i)
+    if (func.getArgAttr(i, attr))
+      return true;
+  return false;
+}
+
 mlir::Type fir::applyPathToType(mlir::Type eleTy, mlir::ValueRange path) {
   for (auto i = path.begin(), end = path.end(); eleTy && i < end;) {
     eleTy = llvm::TypeSwitch<mlir::Type, mlir::Type>(eleTy)
                 .Case<fir::RecordType>([&](fir::RecordType ty) {
                   if (auto *op = (*i++).getDefiningOp()) {
                     if (auto off = mlir::dyn_cast<fir::FieldIndexOp>(op))
                       return ty.getType(off.getFieldName());
                     if (auto off = mlir::dyn_cast<mlir::arith::ConstantOp>(op))

flang/test/Lower/basic-call.f90

+! RUN: bbc %s -o "-" -emit-fir | FileCheck %s
+
+subroutine sub1()
+end
+! CHECK-LABEL: func @_QPsub1()
+
+subroutine sub2()
+  call sub1()
+end
+
+! CHECK-LABEL: func @_QPsub2()
+! CHECK:         fir.call @_QPsub1() : () -> ()
+
+subroutine sub3(a, b)
+  integer :: a
+  real :: b
+end
+
+! CHECK-LABEL: func @_QPsub3(
+! CHECK-SAME:    %{{.*}}: !fir.ref<i32> {fir.bindc_name = "a"},
+! CHECK-SAME:    %{{.*}}: !fir.ref<f32> {fir.bindc_name = "b"})
+
+subroutine sub4()
+  call sub3(2, 3.0)
+end
+
+! CHECK-LABEL: func @_QPsub4() {
+! CHECK-DAG: %[[REAL_VALUE:.*]] = fir.alloca f32 {adapt.valuebyref}
+! CHECK-DAG: %[[INT_VALUE:.*]] = fir.alloca i32 {adapt.valuebyref}
+! CHECK:     %[[C2:.*]] = arith.constant 2 : i32
+! CHECK:     fir.store %[[C2]] to %[[INT_VALUE]] : !fir.ref<i32>
+! CHECK:     %[[C3:.*]] = arith.constant 3.000000e+00 : f32
+! CHECK:     fir.store %[[C3]] to %[[REAL_VALUE]] : !fir.ref<f32>
+! CHECK:     fir.call @_QPsub3(%[[INT_VALUE]], %[[REAL_VALUE]]) : (!fir.ref<i32>, !fir.ref<f32>) -> ()
+
+subroutine call_fct1()
+  real :: a, b, c
+  c = fct1(a, b)
+end
+
+! CHECK-LABEL: func @_QPcall_fct1()
+! CHECK:         %[[A:.*]] = fir.alloca f32 {bindc_name = "a", uniq_name = "_QFcall_fct1Ea"}
+! CHECK:         %[[B:.*]] = fir.alloca f32 {bindc_name = "b", uniq_name = "_QFcall_fct1Eb"}
+! CHECK:         %[[C:.*]] = fir.alloca f32 {bindc_name = "c", uniq_name = "_QFcall_fct1Ec"}
+! CHECK:         %[[RES:.*]] = fir.call @_QPfct1(%[[A]], %[[B]]) : (!fir.ref<f32>, !fir.ref<f32>) -> f32
+! CHECK:         fir.store %[[RES]] to %[[C]] : !fir.ref<f32>
+! CHECK:         return
+
+! CHECK: func private @_QPfct1(!fir.ref<f32>, !fir.ref<f32>) -> f32