[flang] Add lowering for host association

[clementval]

Summary

This patches adds the code to handle host association for
inner subroutines and functions.

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

flang/include/flang/Lower/AbstractConverter.h

public:
   /// 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;
 
+  /// Record a binding for the ssa-value of the host assoications tuple for this
+  /// function.
+  virtual void bindHostAssocTuple(mlir::Value val) = 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

 }
 
 namespace mlir {
 class Location;
 }
 
 namespace Fortran::lower {
 class AbstractConverter;
+class SymMap;
+class HostAssociations;
 namespace pft {
 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

 /// The logic is shared between the callee and caller sides that it accepts as
 /// a curiously recursive template to handle the few things that cannot be
 /// shared between both sides (getting characteristics, mangled name, location).
 /// It maps FIR arguments to front-end Symbol (callee side) or ActualArgument
 /// (caller side) with the same code using the abstract FortranEntity type that
 /// can be either a Symbol or an ActualArgument.
 /// It works in two passes: a first pass over the characteristics that decides
 /// how the interface must be. Then, the funcOp is created for it. Then a simple
-/// pass over fir arguments finalizes the interface information that must be
-/// passed back to the user (and may require having the funcOp). All these
+/// pass over fir arguments finalize the interface information that must be
+/// passed back to the user (and may require having the funcOp). All this
 /// passes are driven from the CallInterface constructor.
 template <typename T>
 class CallInterface {
   friend CallInterfaceImpl<T>;
 
 public:
   /// Enum the different ways an entity can be passed-by
   enum class PassEntityBy {
enum class PassEntityBy {
     Value,
     /// ValueAttribute means dummy has the the Fortran VALUE attribute.
     BaseAddressValueAttribute,
     CharBoxValueAttribute, // BoxChar with VALUE
     // Passing a character procedure as a <procedure address, result length>
     // tuple.
     CharProcTuple
   };
-
   /// Different properties of an entity that can be passed/returned.
   /// One-to-One mapping with PassEntityBy but for
   /// PassEntityBy::AddressAndLength that has two properties.
   enum class Property {
     BaseAddress,
     BoxChar,
     CharAddress,
     CharLength,
public:
   struct FirPlaceHolder {
     FirPlaceHolder(mlir::Type t, int passedPosition, Property p,
                    llvm::ArrayRef<mlir::NamedAttribute> attrs)
         : type{t}, passedEntityPosition{passedPosition}, property{p},
           attributes{attrs.begin(), attrs.end()} {}
     /// Type for this input/output
     mlir::Type type;
     /// Position of related passedEntity in passedArguments.
-    /// (passedEntity is the passedResult this value is resultEntityPosition).
+    /// (passedEntity is the passedResult this value is resultEntityPosition.
     int passedEntityPosition;
     static constexpr int resultEntityPosition = -1;
     /// Indicate property of the entity passedEntityPosition that must be passed
     /// through this argument.
     Property property;
     /// MLIR attributes for this argument
     llvm::SmallVector<mlir::NamedAttribute> attributes;
   };
public:
   /// Return the procedure symbol if this is a call to a user defined
   /// procedure.
   const Fortran::semantics::Symbol *getProcedureSymbol() const;
 
   /// Add mlir::FuncOp entry block and map fir block arguments to Fortran dummy
   /// argument symbols.
   mlir::FuncOp addEntryBlockAndMapArguments();
 
+  bool hasHostAssociated() const;
+  mlir::Type getHostAssociatedTy() const;
+  mlir::Value getHostAssociatedTuple() const;
+
 private:
   Fortran::lower::pft::FunctionLikeUnit &funit;
 };
 
+/// Translate a procedure characteristics to an mlir::FunctionType signature.
+mlir::FunctionType
+translateSignature(const Fortran::evaluate::ProcedureDesignator &,
+                   Fortran::lower::AbstractConverter &);
+
+/// Declare or find the mlir::FuncOp named \p name. If the mlir::FuncOp does
+/// not exist yet, declare it with the signature translated from the
+/// ProcedureDesignator argument.
+/// Due to Fortran implicit function typing rules, the returned FuncOp is not
+/// guaranteed to have the signature from ProcedureDesignator if the FuncOp was
+/// already declared.
+mlir::FuncOp
+getOrDeclareFunction(llvm::StringRef name,
+                     const Fortran::evaluate::ProcedureDesignator &,
+                     Fortran::lower::AbstractConverter &);
+
+/// Return the type of an argument that is a dummy procedure. This may be an
+/// mlir::FunctionType, but it can also be a more elaborate type based on the
+/// function type (like a tuple<function type, length type> for character
+/// functions).
+mlir::Type getDummyProcedureType(const Fortran::semantics::Symbol &dummyProc,
+                                 Fortran::lower::AbstractConverter &);
+
+/// Is it required to pass \p proc as a tuple<function address, result length> ?
+// This is required to convey  the length of character functions passed as dummy
+// procedures.
+bool mustPassLengthWithDummyProcedure(
+    const Fortran::evaluate::ProcedureDesignator &proc,
+    Fortran::lower::AbstractConverter &);
+
 } // namespace Fortran::lower
 
 #endif // FORTRAN_LOWER_FIRBUILDER_H

flang/include/flang/Optimizer/Builder/BoxValue.h

public:
   /// Is this a Fortran pointer ?
   bool isPointer() const {
     return getBoxTy().getEleTy().isa<fir::PointerType>();
   }
   /// Is this an allocatable ?
   bool isAllocatable() const {
     return getBoxTy().getEleTy().isa<fir::HeapType>();
   }
-  /// Does this entity have any non deferred length parameters ?
+  // Replace the fir.ref<fir.box>, keeping any non-deferred parameters.
+  MutableBoxValue clone(mlir::Value newBox) const {
+    return {newBox, lenParams, mutableProperties};
+  }
+  /// Does this entity has any non deferred length parameters ?
   bool hasNonDeferredLenParams() const { return !lenParams.empty(); }
   /// Return the non deferred length parameters.
   llvm::ArrayRef<mlir::Value> nonDeferredLenParams() const { return lenParams; }
   friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
                                        const MutableBoxValue &);
   LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
 
-  /// Set of variables is used instead of a descriptor to hold the entity
+  /// Set of variable is used instead of a descriptor to hold the entity
   /// properties instead of a fir.ref<fir.box<>>.
   bool isDescribedByVariables() const { return !mutableProperties.isEmpty(); }
 
   const MutableProperties &getMutableProperties() const {
     return mutableProperties;
   }
 
 protected:

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

+//===-- LowLevelIntrinsics.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 FLANG_OPTIMIZER_BUILDER_LOWLEVELINTRINSICS_H
+#define FLANG_OPTIMIZER_BUILDER_LOWLEVELINTRINSICS_H
+
+namespace mlir {
+class FuncOp;
+}
+namespace fir {
+class FirOpBuilder;
+}
+
+namespace fir::factory {
+
+/// Get the `llvm.stacksave` intrinsic.
+mlir::FuncOp getLlvmStackSave(FirOpBuilder &builder);
+
+/// Get the `llvm.stackrestore` intrinsic.
+mlir::FuncOp getLlvmStackRestore(FirOpBuilder &builder);
+
+} // namespace fir::factory
+
+#endif // FLANG_OPTIMIZER_BUILDER_LOWLEVELINTRINSICS_H

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

 
 /// Return true iff `ty` is a RecordType with type parameters.
 inline bool isRecordWithTypeParameters(mlir::Type ty) {
   if (auto recTy = ty.dyn_cast_or_null<fir::RecordType>())
     return recTy.getNumLenParams() != 0;
   return false;
 }
 
+/// Is this tuple type holding a character function and its result length ?
+bool isCharacterProcedureTuple(mlir::Type type, bool acceptRawFunc = true);
+
 /// Apply the components specified by `path` to `rootTy` to determine the type
 /// of the resulting component element. `rootTy` should be an aggregate type.
 /// Returns null on error.
 mlir::Type applyPathToType(mlir::Type rootTy, mlir::ValueRange path);
 
 } // namespace fir
 
 #endif // FORTRAN_OPTIMIZER_DIALECT_FIRTYPE_H

flang/lib/Lower/Bridge.cpp

for (int entryIndex = 0, last = funit.entryPointList.size();
       // it later when lowering the body. CalleeInterface ctor should be linear
       // with the number of arguments, so it is not awful to do it that way for
       // now, but the linear coefficient might be non negligible. Until
       // measured, stick to the solution that impacts the code less.
       Fortran::lower::CalleeInterface{funit, *this};
     }
     funit.setActiveEntry(0);
 
+    // Compute the set of host associated entities from the nested functions.
+    llvm::SetVector<const Fortran::semantics::Symbol *> escapeHost;
+    for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
+      collectHostAssociatedVariables(f, escapeHost);
+    funit.setHostAssociatedSymbols(escapeHost);
+
     // Declare internal procedures
     for (Fortran::lower::pft::FunctionLikeUnit &f : funit.nestedFunctions)
       declareFunction(f);
   }
 
+  /// Collects the canonical list of all host associated symbols. These bindings
+  /// must be aggregated into a tuple which can then be added to each of the
+  /// internal procedure declarations and passed at each call site.
+  void collectHostAssociatedVariables(
+      Fortran::lower::pft::FunctionLikeUnit &funit,
+      llvm::SetVector<const Fortran::semantics::Symbol *> &escapees) {
+    const Fortran::semantics::Scope *internalScope =
+        funit.getSubprogramSymbol().scope();
+    assert(internalScope && "internal procedures symbol must create a scope");
+    auto addToListIfEscapee = [&](const Fortran::semantics::Symbol &sym) {
+      const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
+      const auto *namelistDetails =
+          ultimate.detailsIf<Fortran::semantics::NamelistDetails>();
+      if (ultimate.has<Fortran::semantics::ObjectEntityDetails>() ||
+          Fortran::semantics::IsProcedurePointer(ultimate) ||
+          Fortran::semantics::IsDummy(sym) || namelistDetails) {
+        const Fortran::semantics::Scope &ultimateScope = ultimate.owner();
+        if (ultimateScope.kind() ==
+                Fortran::semantics::Scope::Kind::MainProgram ||
+            ultimateScope.kind() == Fortran::semantics::Scope::Kind::Subprogram)
+          if (ultimateScope != *internalScope &&
+              ultimateScope.Contains(*internalScope)) {
+            if (namelistDetails) {
+              // So far, namelist symbols are processed on the fly in IO and
+              // the related namelist data structure is not added to the symbol
+              // map, so it cannot be passed to the internal procedures.
+              // Instead, all the symbols of the host namelist used in the
+              // internal procedure must be considered as host associated so
+              // that IO lowering can find them when needed.
+              for (const auto &namelistObject : namelistDetails->objects())
+                escapees.insert(&*namelistObject);
+            } else {
+              escapees.insert(&ultimate);
+            }
+          }
+      }
+    };
+    Fortran::lower::pft::visitAllSymbols(funit, addToListIfEscapee);
+  }
+
   //===--------------------------------------------------------------------===//
   // AbstractConverter overrides
   //===--------------------------------------------------------------------===//
 
   mlir::Value getSymbolAddress(Fortran::lower::SymbolRef sym) override final {
     return lookupSymbol(sym).getAddr();
   }
 
auto mapPassedEntity = [&](const auto arg) -> void {
         fir::factory::CharacterExprHelper charHelp{*builder, loc};
         mlir::Value box =
             charHelp.createEmboxChar(arg.firArgument, arg.firLength);
         addSymbol(arg.entity->get(), box);
       } else {
         if (arg.entity.has_value()) {
           addSymbol(arg.entity->get(), arg.firArgument);
         } else {
-          // assert(funit.parentHasHostAssoc());
-          // funit.parentHostAssoc().internalProcedureBindings(*this,
-          //                                                   localSymbols);
+          assert(funit.parentHasHostAssoc());
+          funit.parentHostAssoc().internalProcedureBindings(*this,
+                                                            localSymbols);
         }
       }
     };
     for (const Fortran::lower::CalleeInterface::PassedEntity &arg :
          callee.getPassedArguments())
       mapPassedEntity(arg);
 
     // Allocate local skeleton instances of dummies from other entry points.
void startNewFunction(Fortran::lower::pft::FunctionLikeUnit &funit) {
     mlir::FuncOp func = callee.addEntryBlockAndMapArguments();
     func.setVisibility(mlir::SymbolTable::Visibility::Public);
     builder = new fir::FirOpBuilder(func, bridge.getKindMap());
     assert(builder && "FirOpBuilder did not instantiate");
     builder->setInsertionPointToStart(&func.front());
 
     mapDummiesAndResults(funit, callee);
 
+    // Note: not storing Variable references because getOrderedSymbolTable
+    // below returns a temporary.
+    llvm::SmallVector<Fortran::lower::pft::Variable> deferredFuncResultList;
+
+    // Backup actual argument for entry character results
+    // with different lengths. It needs to be added to the non
+    // primary results symbol before mapSymbolAttributes is called.
+    Fortran::lower::SymbolBox resultArg;
+    if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
+            passedResult = callee.getPassedResult())
+      resultArg = lookupSymbol(passedResult->entity->get());
+
     Fortran::lower::AggregateStoreMap storeMap;
+    // The front-end is currently not adding module variables referenced
+    // in a module procedure as host associated. As a result we need to
+    // instantiate all module variables here if this is a module procedure.
+    // It is likely that the front-end behavior should change here.
+    // This also applies to internal procedures inside module procedures.
+    if (auto *module = Fortran::lower::pft::getAncestor<
+            Fortran::lower::pft::ModuleLikeUnit>(funit))
+      for (const Fortran::lower::pft::Variable &var :
+           module->getOrderedSymbolTable())
+        instantiateVar(var, storeMap);
+
+    mlir::Value primaryFuncResultStorage;
     for (const Fortran::lower::pft::Variable &var :
          funit.getOrderedSymbolTable()) {
+      // Always instantiate aggregate storage blocks.
+      if (var.isAggregateStore()) {
+        instantiateVar(var, storeMap);
+        continue;
+      }
       const Fortran::semantics::Symbol &sym = var.getSymbol();
+      if (funit.parentHasHostAssoc()) {
+        // Never instantitate host associated variables, as they are already
+        // instantiated from an argument tuple. Instead, just bind the symbol to
+        // the reference to the host variable, which must be in the map.
+        const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
+        if (funit.parentHostAssoc().isAssociated(ultimate)) {
+          Fortran::lower::SymbolBox hostBox =
+              localSymbols.lookupSymbol(ultimate);
+          assert(hostBox && "host association is not in map");
+          localSymbols.addSymbol(sym, hostBox.toExtendedValue());
+          continue;
+        }
+      }
       if (!sym.IsFuncResult() || !funit.primaryResult) {
         instantiateVar(var, storeMap);
       } else if (&sym == funit.primaryResult) {
         instantiateVar(var, storeMap);
-      }
+        primaryFuncResultStorage = getSymbolAddress(sym);
+      } else {
+        deferredFuncResultList.push_back(var);
+      }
+
+    // If this is a host procedure with host associations, then create the tuple
+    // of pointers for passing to the internal procedures.
+    if (!funit.getHostAssoc().empty())
+      funit.getHostAssoc().hostProcedureBindings(*this, localSymbols);
+
+    /// TODO: should use same mechanism as equivalence?
+    /// One blocking point is character entry returns that need special handling
+    /// since they are not locally allocated but come as argument. CHARACTER(*)
+    /// is not something that fit wells with equivalence lowering.
+    for (const Fortran::lower::pft::Variable &altResult :
+         deferredFuncResultList) {
+      if (std::optional<Fortran::lower::CalleeInterface::PassedEntity>
+              passedResult = callee.getPassedResult())
+        addSymbol(altResult.getSymbol(), resultArg.getAddr());
+      Fortran::lower::StatementContext stmtCtx;
+      Fortran::lower::mapSymbolAttributes(*this, altResult, localSymbols,
+                                          stmtCtx, primaryFuncResultStorage);
     }
 
     // Create most function blocks in advance.
     createEmptyGlobalBlocks(funit.evaluationList);
 
     // Reinstate entry block as the current insertion point.
     builder->setInsertionPointToEnd(&func.front());
+
+    if (callee.hasAlternateReturns()) {
+      // Create a local temp to hold the alternate return index.
+      // Give it an integer index type and the subroutine name (for dumps).
+      // Attach it to the subroutine symbol in the localSymbols map.
+      // Initialize it to zero, the "fallthrough" alternate return value.
+      const Fortran::semantics::Symbol &symbol = funit.getSubprogramSymbol();
+      mlir::Location loc = toLocation();
+      mlir::Type idxTy = builder->getIndexType();
+      mlir::Value altResult =
+          builder->createTemporary(loc, idxTy, toStringRef(symbol.name()));
+      addSymbol(symbol, altResult);
+      mlir::Value zero = builder->createIntegerConstant(loc, idxTy, 0);
+      builder->create<fir::StoreOp>(loc, zero, altResult);
+    }
+
+    if (Fortran::lower::pft::Evaluation *alternateEntryEval =
+            funit.getEntryEval())
+      genFIRBranch(alternateEntryEval->lexicalSuccessor->block);
   }
 
   /// Create global blocks for the current function.  This eliminates the
   /// distinction between forward and backward targets when generating
   /// branches.  A block is "global" if it can be the target of a GOTO or
   /// other source code branch.  A block that can only be targeted by a
   /// compiler generated branch is "local".  For example, a DO loop preheader
   /// block containing loop initialization code is global.  A loop header
   /// block, which is the target of the loop back edge, is local.  Blocks
   /// belong to a region.  Any block within a nested region must be replaced
   /// with a block belonging to that region.  Branches may not cross region
   /// boundaries.
   void createEmptyGlobalBlocks(
       std::list<Fortran::lower::pft::Evaluation> &evaluationList) {
     mlir::Region *region = &builder->getRegion();
     for (Fortran::lower::pft::Evaluation &eval : evaluationList) {
       if (eval.isNewBlock)
         eval.block = builder->createBlock(region);
       if (eval.isConstruct() || eval.isDirective()) {
         if (eval.lowerAsUnstructured()) {
           createEmptyGlobalBlocks(eval.getNestedEvaluations());
         } else if (eval.hasNestedEvaluations()) {
-          TODO(toLocation(), "Constructs with nested evaluations");
+          // A structured construct that is a target starts a new block.
+          Fortran::lower::pft::Evaluation &constructStmt =
+              eval.getFirstNestedEvaluation();
+          if (constructStmt.isNewBlock)
+            constructStmt.block = builder->createBlock(region);
         }
       }
     }
   }
 
   /// Lower a procedure (nest).
   void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
+    if (!funit.isMainProgram()) {
+      const Fortran::semantics::Symbol &procSymbol =
+          funit.getSubprogramSymbol();
+      if (procSymbol.owner().IsSubmodule()) {
+        TODO(toLocation(), "support submodules");
+        return;
+      }
+    }
     setCurrentPosition(funit.getStartingSourceLoc());
     for (int entryIndex = 0, last = funit.entryPointList.size();
          entryIndex < last; ++entryIndex) {
       funit.setActiveEntry(entryIndex);
       startNewFunction(funit); // the entry point for lowering this procedure
       for (Fortran::lower::pft::Evaluation &eval : funit.evaluationList)
         genFIR(eval);
       endNewFunction(funit);
public:
   /// Lower functions contained in a module.
   void lowerMod(Fortran::lower::pft::ModuleLikeUnit &mod) {
     for (Fortran::lower::pft::FunctionLikeUnit &f : mod.nestedFunctions)
       lowerFunc(f);
   }
 
   mlir::Value hostAssocTupleValue() override final { return hostAssocTuple; }
 
+  /// Record a binding for the ssa-value of the tuple for this function.
+  void bindHostAssocTuple(mlir::Value val) override final {
+    assert(!hostAssocTuple && val);
+    hostAssocTuple = val;
+  }
+
 private:
   FirConverter() = delete;
   FirConverter(const FirConverter &) = delete;
   FirConverter &operator=(const FirConverter &) = delete;
 
   //===--------------------------------------------------------------------===//
   // Helper member functions
   //===--------------------------------------------------------------------===//
 
+  mlir::Value createFIRExpr(mlir::Location loc,
+                            const Fortran::lower::SomeExpr *expr,
+                            Fortran::lower::StatementContext &stmtCtx) {
+    return fir::getBase(genExprValue(*expr, stmtCtx, &loc));
+  }
+
   /// Find the symbol in the local map or return null.
   Fortran::lower::SymbolBox
   lookupSymbol(const Fortran::semantics::Symbol &sym) {
     if (Fortran::lower::SymbolBox v = localSymbols.lookupSymbol(sym))
       return v;
     return {};
   }
 
mlir::Block *blockOfLabel(Fortran::lower::pft::Evaluation &eval,
     return block;
   }
 
   void genFIRBranch(mlir::Block *targetBlock) {
     assert(targetBlock && "missing unconditional target block");
     builder->create<cf::BranchOp>(toLocation(), targetBlock);
   }
 
+  void genFIRConditionalBranch(mlir::Value cond, mlir::Block *trueTarget,
+                               mlir::Block *falseTarget) {
+    assert(trueTarget && "missing conditional branch true block");
+    assert(falseTarget && "missing conditional branch false block");
+    mlir::Location loc = toLocation();
+    mlir::Value bcc = builder->createConvert(loc, builder->getI1Type(), cond);
+    builder->create<mlir::cf::CondBranchOp>(loc, bcc, trueTarget, llvm::None,
+                                            falseTarget, llvm::None);
+  }
+  void genFIRConditionalBranch(mlir::Value cond,
+                               Fortran::lower::pft::Evaluation *trueTarget,
+                               Fortran::lower::pft::Evaluation *falseTarget) {
+    genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block);
+  }
+  void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
+                               mlir::Block *trueTarget,
+                               mlir::Block *falseTarget) {
+    Fortran::lower::StatementContext stmtCtx;
+    mlir::Value cond =
+        createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
+    stmtCtx.finalize();
+    genFIRConditionalBranch(cond, trueTarget, falseTarget);
+  }
+  void genFIRConditionalBranch(const Fortran::parser::ScalarLogicalExpr &expr,
+                               Fortran::lower::pft::Evaluation *trueTarget,
+                               Fortran::lower::pft::Evaluation *falseTarget) {
+    Fortran::lower::StatementContext stmtCtx;
+    mlir::Value cond =
+        createFIRExpr(toLocation(), Fortran::semantics::GetExpr(expr), stmtCtx);
+    stmtCtx.finalize();
+    genFIRConditionalBranch(cond, trueTarget->block, falseTarget->block);
+  }
+
   //===--------------------------------------------------------------------===//
   // Termination of symbolically referenced execution units
   //===--------------------------------------------------------------------===//
 
   /// END of program
   ///
   /// Generate the cleanup block before the program exits
   void genExitRoutine() {
void genFIRProcedureExit(Fortran::lower::pft::FunctionLikeUnit &funit,
     }
     if (Fortran::semantics::IsFunction(symbol)) {
       genReturnSymbol(symbol);
     } else {
       genExitRoutine();
     }
   }
 
+  //
+  // Statements that have control-flow semantics
+  //
+
+  /// Generate an If[Then]Stmt condition or its negation.
+  template <typename A>
+  mlir::Value genIfCondition(const A *stmt, bool negate = false) {
+    mlir::Location loc = toLocation();
+    Fortran::lower::StatementContext stmtCtx;
+    mlir::Value condExpr = createFIRExpr(
+        loc,
+        Fortran::semantics::GetExpr(
+            std::get<Fortran::parser::ScalarLogicalExpr>(stmt->t)),
+        stmtCtx);
+    stmtCtx.finalize();
+    mlir::Value cond =
+        builder->createConvert(loc, builder->getI1Type(), condExpr);
+    if (negate)
+      cond = builder->create<mlir::arith::XOrIOp>(
+          loc, cond, builder->createIntegerConstant(loc, cond.getType(), 1));
+    return cond;
+  }
+
   [[maybe_unused]] static bool
   isFuncResultDesignator(const Fortran::lower::SomeExpr &expr) {
     const Fortran::semantics::Symbol *sym =
         Fortran::evaluate::GetFirstSymbol(expr);
     return sym && sym->IsFuncResult();
   }
 
   static bool isWholeAllocatable(const Fortran::lower::SomeExpr &expr) {
void genFIR(const Fortran::parser::AssignedGotoStmt &stmt) {
     TODO(toLocation(), "AssignedGotoStmt lowering");
   }
 
   void genFIR(const Fortran::parser::DoConstruct &doConstruct) {
     TODO(toLocation(), "DoConstruct lowering");
   }
 
   void genFIR(const Fortran::parser::IfConstruct &) {
-    TODO(toLocation(), "IfConstruct lowering");
+    mlir::Location loc = toLocation();
+    Fortran::lower::pft::Evaluation &eval = getEval();
+    if (eval.lowerAsStructured()) {
+      // Structured fir.if nest.
+      fir::IfOp topIfOp, currentIfOp;
+      for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
+        auto genIfOp = [&](mlir::Value cond) {
+          auto ifOp = builder->create<fir::IfOp>(loc, cond, /*withElse=*/true);
+          builder->setInsertionPointToStart(&ifOp.getThenRegion().front());
+          return ifOp;
+        };
+        if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
+          topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
+        } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
+          topIfOp = currentIfOp = genIfOp(genIfCondition(s, e.negateCondition));
+        } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
+          builder->setInsertionPointToStart(
+              &currentIfOp.getElseRegion().front());
+          currentIfOp = genIfOp(genIfCondition(s));
+        } else if (e.isA<Fortran::parser::ElseStmt>()) {
+          builder->setInsertionPointToStart(
+              &currentIfOp.getElseRegion().front());
+        } else if (e.isA<Fortran::parser::EndIfStmt>()) {
+          builder->setInsertionPointAfter(topIfOp);
+        } else {
+          genFIR(e, /*unstructuredContext=*/false);
+        }
+      }
+      return;
+    }
+
+    // Unstructured branch sequence.
+    for (Fortran::lower::pft::Evaluation &e : eval.getNestedEvaluations()) {
+      auto genIfBranch = [&](mlir::Value cond) {
+        if (e.lexicalSuccessor == e.controlSuccessor) // empty block -> exit
+          genFIRConditionalBranch(cond, e.parentConstruct->constructExit,
+                                  e.controlSuccessor);
+        else // non-empty block
+          genFIRConditionalBranch(cond, e.lexicalSuccessor, e.controlSuccessor);
+      };
+      if (auto *s = e.getIf<Fortran::parser::IfThenStmt>()) {
+        maybeStartBlock(e.block);
+        genIfBranch(genIfCondition(s, e.negateCondition));
+      } else if (auto *s = e.getIf<Fortran::parser::IfStmt>()) {
+        maybeStartBlock(e.block);
+        genIfBranch(genIfCondition(s, e.negateCondition));
+      } else if (auto *s = e.getIf<Fortran::parser::ElseIfStmt>()) {
+        startBlock(e.block);
+        genIfBranch(genIfCondition(s));
+      } else {
+        genFIR(e);
+      }
+    }
   }
 
   void genFIR(const Fortran::parser::CaseConstruct &) {
     TODO(toLocation(), "CaseConstruct lowering");
   }
 
   void genFIR(const Fortran::parser::ConcurrentHeader &header) {
     TODO(toLocation(), "ConcurrentHeader lowering");

flang/lib/Lower/CMakeLists.txt

 get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS)
 
 add_flang_library(FortranLower
   Allocatable.cpp
   Bridge.cpp
   CallInterface.cpp
   Coarray.cpp
   ConvertExpr.cpp
   ConvertType.cpp
   ConvertVariable.cpp
-  IntrinsicCall.cpp
-  IO.cpp
   ComponentPath.cpp
   DumpEvaluateExpr.cpp
+  HostAssociations.cpp
+  IntrinsicCall.cpp
+  IO.cpp
   IterationSpace.cpp
   Mangler.cpp
   OpenACC.cpp
   OpenMP.cpp
   PFTBuilder.cpp
   Runtime.cpp
   SymbolMap.cpp
 

flang/lib/Lower/CallInterface.cpp

 //===-- CallInterface.cpp -- Procedure call interface ---------------------===//
 //
 // 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/CallInterface.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Lower/Bridge.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Support/Utils.h"
 #include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Dialect/FIRDialect.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Optimizer/Support/InternalNames.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 
 //===----------------------------------------------------------------------===//
 // BIND(C) mangling helpers
 //===----------------------------------------------------------------------===//
 
 // 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);
 }
 
+/// Return the type of a dummy procedure given its characteristic (if it has
+/// one).
+mlir::Type getProcedureDesignatorType(
+    const Fortran::evaluate::characteristics::Procedure *,
+    Fortran::lower::AbstractConverter &converter) {
+  // TODO: Get actual function type of the dummy procedure, at least when an
+  // interface is given. The result type should be available even if the arity
+  // and type of the arguments is not.
+  llvm::SmallVector<mlir::Type> resultTys;
+  llvm::SmallVector<mlir::Type> inputTys;
+  // In general, that is a nice to have but we cannot guarantee to find the
+  // function type that will match the one of the calls, we may not even know
+  // how many arguments the dummy procedure accepts (e.g. if a procedure
+  // pointer is only transiting through the current procedure without being
+  // called), so a function type cast must always be inserted.
+  auto *context = &converter.getMLIRContext();
+  auto untypedFunc = mlir::FunctionType::get(context, inputTys, resultTys);
+  return fir::BoxProcType::get(context, untypedFunc);
+}
+
 //===----------------------------------------------------------------------===//
 // Caller side interface implementation
 //===----------------------------------------------------------------------===//
 
 bool Fortran::lower::CallerInterface::hasAlternateReturns() const {
   return procRef.hasAlternateReturns();
 }
 
void Fortran::lower::CallerInterface::walkResultLengths(
   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");
+    TODO(converter.getCurrentLocation(), "walkResultLengths derived type");
   }
 }
 
 // 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) {

 mlir::FuncOp Fortran::lower::CalleeInterface::addEntryBlockAndMapArguments() {
   // On the callee side, directly map the mlir::value argument of
   // the function block to the Fortran symbols.
   func.addEntryBlock();
   mapPassedEntities();
   return func;
 }
 
+bool Fortran::lower::CalleeInterface::hasHostAssociated() const {
+  return funit.parentHasHostAssoc();
+}
+
+mlir::Type Fortran::lower::CalleeInterface::getHostAssociatedTy() const {
+  assert(hasHostAssociated());
+  return funit.parentHostAssoc().getArgumentType(converter);
+}
+
+mlir::Value Fortran::lower::CalleeInterface::getHostAssociatedTuple() const {
+  assert(hasHostAssociated() || !funit.getHostAssoc().empty());
+  return converter.hostAssocTupleValue();
+}
+
 //===----------------------------------------------------------------------===//
-// CallInterface implementation: this part is common to both callee and caller
+// CallInterface implementation: this part is common to both caller and caller
 // sides.
 //===----------------------------------------------------------------------===//
 
 static void addSymbolAttribute(mlir::FuncOp func,
                                const Fortran::semantics::Symbol &sym,
                                mlir::MLIRContext &mlirContext) {
   // Only add this on bind(C) functions for which the symbol is not reflected in
   // the current context.

 
 static const Fortran::semantics::Symbol &
 getResultEntity(Fortran::lower::pft::FunctionLikeUnit &funit) {
   return funit.getSubprogramSymbol()
       .get<Fortran::semantics::SubprogramDetails>()
       .result();
 }
 
-//===----------------------------------------------------------------------===//
-// CallInterface implementation: this part is common to both caller and caller
-// sides.
-//===----------------------------------------------------------------------===//
+/// Bypass helpers to manipulate entities since they are not any symbol/actual
+/// argument to associate. See SignatureBuilder below.
+using FakeEntity = bool;
+using FakeEntities = llvm::SmallVector<FakeEntity>;
+static FakeEntities
+getEntityContainer(const Fortran::evaluate::characteristics::Procedure &proc) {
+  FakeEntities enities(proc.dummyArguments.size());
+  return enities;
+}
+static const FakeEntity &getDataObjectEntity(const FakeEntity &e) { return e; }
+static FakeEntity
+getResultEntity(const Fortran::evaluate::characteristics::Procedure &proc) {
+  return false;
+}
 
 /// This is the actual part that defines the FIR interface based on the
 /// characteristic. It directly mutates the CallInterface members.
 template <typename T>
 class Fortran::lower::CallInterfaceImpl {
   using CallInterface = Fortran::lower::CallInterface<T>;
   using PassEntityBy = typename CallInterface::PassEntityBy;
   using PassedEntity = typename CallInterface::PassedEntity;
for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) {
               [&](const Fortran::evaluate::characteristics::AlternateReturn &) {
                 // nothing to do
               },
           },
           argCharacteristics.u);
     }
   }
 
+  void appendHostAssocTupleArg(mlir::Type tupTy) {
+    MLIRContext *ctxt = tupTy.getContext();
+    addFirOperand(tupTy, nextPassedArgPosition(), Property::BaseAddress,
+                  {mlir::NamedAttribute{
+                      mlir::StringAttr::get(ctxt, fir::getHostAssocAttrName()),
+                      mlir::UnitAttr::get(ctxt)}});
+    interface.passedArguments.emplace_back(
+        PassedEntity{PassEntityBy::BaseAddress, std::nullopt,
+                     interface.side().getHostAssociatedTuple(), emptyValue()});
+  }
+
+  static llvm::Optional<Fortran::evaluate::DynamicType> getResultDynamicType(
+      const Fortran::evaluate::characteristics::Procedure &procedure) {
+    if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
+            &result = procedure.functionResult)
+      if (const auto *resultTypeAndShape = result->GetTypeAndShape())
+        return resultTypeAndShape->type();
+    return llvm::None;
+  }
+
+  static bool mustPassLengthWithDummyProcedure(
+      const Fortran::evaluate::characteristics::Procedure &procedure) {
+    // When passing a character function designator `bar` as dummy procedure to
+    // `foo` (e.g. `foo(bar)`), pass the result length of `bar` to `foo` so that
+    // `bar` can be called inside `foo` even if its length is assumed there.
+    // From an ABI perspective, the extra length argument must be handled
+    // exactly as if passing a character object. Using an argument of
+    // fir.boxchar type gives the expected behavior: after codegen, the
+    // fir.boxchar lengths are added after all the arguments as extra value
+    // arguments (the extra arguments order is the order of the fir.boxchar).
+
+    // This ABI is compatible with ifort, nag, nvfortran, and xlf, but not
+    // gfortran. Gfortran does not pass the length and is therefore unable to
+    // handle later call to `bar` in `foo` where the length would be assumed. If
+    // the result is an array, nag and ifort and xlf still pass the length, but
+    // not nvfortran (and gfortran). It is not clear it is possible to call an
+    // array function with assumed length (f18 forbides defining such
+    // interfaces). Hence, passing the length is most likely useless, but stick
+    // with ifort/nag/xlf interface here.
+    if (llvm::Optional<Fortran::evaluate::DynamicType> type =
+            getResultDynamicType(procedure))
+      return type->category() == Fortran::common::TypeCategory::Character;
+    return false;
+  }
+
 private:
   void handleImplicitResult(
       const Fortran::evaluate::characteristics::FunctionResult &result) {
     if (result.IsProcedurePointer())
       TODO(interface.converter.getCurrentLocation(),
            "procedure pointer result not yet handled");
     const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
         result.GetTypeAndShape();
     assert(typeAndShape && "expect type for non proc pointer result");
     Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
     // Character result allocated by caller and passed as hidden arguments
     if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
       handleImplicitCharacterResult(dynamicType);
     } else if (dynamicType.category() ==
                Fortran::common::TypeCategory::Derived) {
-      TODO(interface.converter.getCurrentLocation(),
-           "implicit result derived type");
+      // Derived result need to be allocated by the caller and the result value
+      // must be saved. Derived type in implicit interface cannot have length
+      // parameters.
+      setSaveResult();
+      mlir::Type mlirType = translateDynamicType(dynamicType);
+      addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
+                   Property::Value);
     } else {
       // All result other than characters/derived are simply returned by value
       // in implicit interfaces
       mlir::Type mlirType =
           getConverter().genType(dynamicType.category(), dynamicType.kind());
       addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
                    Property::Value);
     }
   }
-
   void
   handleImplicitCharacterResult(const Fortran::evaluate::DynamicType &type) {
     int resultPosition = FirPlaceHolder::resultEntityPosition;
     setPassedResult(PassEntityBy::AddressAndLength,
                     getResultEntity(interface.side().getCallDescription()));
     mlir::Type lenTy = mlir::IndexType::get(&mlirContext);
     std::optional<std::int64_t> constantLen = type.knownLength();
     fir::CharacterType::LenType len =
         constantLen ? *constantLen : fir::CharacterType::unknownLen();
     mlir::Type charRefTy = fir::ReferenceType::get(
         fir::CharacterType::get(&mlirContext, type.kind(), len));
     mlir::Type boxCharTy = fir::BoxCharType::get(&mlirContext, type.kind());
     addFirOperand(charRefTy, resultPosition, Property::CharAddress);
     addFirOperand(lenTy, resultPosition, Property::CharLength);
     /// For now, also return it by boxchar
     addFirResult(boxCharTy, resultPosition, Property::BoxChar);
   }
 
-  void handleExplicitResult(
-      const Fortran::evaluate::characteristics::FunctionResult &result) {
-    using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
-
-    if (result.IsProcedurePointer())
-      TODO(interface.converter.getCurrentLocation(),
-           "procedure pointer results");
-    const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
-        result.GetTypeAndShape();
-    assert(typeAndShape && "expect type for non proc pointer result");
-    mlir::Type mlirType = translateDynamicType(typeAndShape->type());
-    fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
-    if (!bounds.empty())
-      mlirType = fir::SequenceType::get(bounds, mlirType);
-    if (result.attrs.test(Attr::Allocatable))
-      mlirType = fir::BoxType::get(fir::HeapType::get(mlirType));
-    if (result.attrs.test(Attr::Pointer))
-      mlirType = fir::BoxType::get(fir::PointerType::get(mlirType));
-
-    if (fir::isa_char(mlirType)) {
-      // Character scalar results must be passed as arguments in lowering so
-      // that an assumed length character function callee can access the result
-      // length. A function with a result requiring an explicit interface does
-      // not have to be compatible with assumed length function, but most
-      // compilers supports it.
-      handleImplicitCharacterResult(typeAndShape->type());
-      return;
-    }
-
-    addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
-                 Property::Value);
-    // Explicit results require the caller to allocate the storage and save the
-    // function result in the storage with a fir.save_result.
-    setSaveResult();
-  }
-
-  fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
-    fir::SequenceType::Shape bounds;
-    for (const std::optional<Fortran::evaluate::ExtentExpr> &extent : shape) {
-      fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent();
-      if (std::optional<std::int64_t> i = toInt64(extent))
-        bound = *i;
-      bounds.emplace_back(bound);
-    }
-    return bounds;
-  }
-  std::optional<std::int64_t>
-  toInt64(std::optional<
-          Fortran::evaluate::Expr<Fortran::evaluate::SubscriptInteger>>
-              expr) {
-    if (expr)
-      return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(
-          getConverter().getFoldingContext(), toEvExpr(*expr)));
-    return std::nullopt;
-  }
-
   /// Return a vector with an attribute with the name of the argument if this
   /// is a callee interface and the name is available. Otherwise, just return
   /// an empty vector.
   llvm::SmallVector<mlir::NamedAttribute>
   dummyNameAttr(const FortranEntity &entity) {
     if constexpr (std::is_same_v<FortranEntity,
                                  std::optional<Fortran::common::Reference<
                                      const Fortran::semantics::Symbol>>>) {
       if (entity.has_value()) {
         const Fortran::semantics::Symbol *argument = &*entity.value();
         // "fir.bindc_name" is used for arguments for the sake of consistency
         // with other attributes carrying surface syntax names in FIR.
         return {mlir::NamedAttribute(
             mlir::StringAttr::get(&mlirContext, "fir.bindc_name"),
             mlir::StringAttr::get(&mlirContext,
                                   toStringRef(argument->name())))};
       }
     }
     return {};
   }
 
+  void handleImplicitDummy(
+      const DummyCharacteristics *characteristics,
+      const Fortran::evaluate::characteristics::DummyDataObject &obj,
+      const FortranEntity &entity) {
+    Fortran::evaluate::DynamicType dynamicType = obj.type.type();
+    if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
+      mlir::Type boxCharTy =
+          fir::BoxCharType::get(&mlirContext, dynamicType.kind());
+      addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,
+                    dummyNameAttr(entity));
+      addPassedArg(PassEntityBy::BoxChar, entity, characteristics);
+    } else {
+      // non-PDT derived type allowed in implicit interface.
+      mlir::Type type = translateDynamicType(dynamicType);
+      fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
+      if (!bounds.empty())
+        type = fir::SequenceType::get(bounds, type);
+      mlir::Type refType = fir::ReferenceType::get(type);
+      addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
+                    dummyNameAttr(entity));
+      addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
+    }
+  }
+
   // Define when an explicit argument must be passed in a fir.box.
   bool dummyRequiresBox(
       const Fortran::evaluate::characteristics::DummyDataObject &obj) {
     using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
     using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attrs;
     constexpr ShapeAttrs shapeRequiringBox = {
         ShapeAttr::AssumedShape, ShapeAttr::DeferredShape,
         ShapeAttr::AssumedRank, ShapeAttr::Coarray};
private:
   }
 
   mlir::Type
   translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) {
     Fortran::common::TypeCategory cat = dynamicType.category();
     // DERIVED
     if (cat == Fortran::common::TypeCategory::Derived) {
       TODO(interface.converter.getCurrentLocation(),
-           "[translateDynamicType] Derived");
+           "[translateDynamicType] Derived types");
     }
     // CHARACTER with compile time constant length.
     if (cat == Fortran::common::TypeCategory::Character)
       if (std::optional<std::int64_t> constantLen =
               toInt64(dynamicType.GetCharLength()))
         return getConverter().genType(cat, dynamicType.kind(), {*constantLen});
     // INTEGER, REAL, LOGICAL, COMPLEX, and CHARACTER with dynamic length.
     return getConverter().genType(cat, dynamicType.kind());
if (obj.attrs.test(Attrs::Allocatable) || obj.attrs.test(Attrs::Pointer)) {
       }
       addFirOperand(passType, nextPassedArgPosition(), prop, attrs);
       addPassedArg(passBy, entity, characteristics);
     }
   }
 
   void handleImplicitDummy(
       const DummyCharacteristics *characteristics,
-      const Fortran::evaluate::characteristics::DummyDataObject &obj,
+      const Fortran::evaluate::characteristics::DummyProcedure &proc,
       const FortranEntity &entity) {
-    Fortran::evaluate::DynamicType dynamicType = obj.type.type();
-    if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
-      mlir::Type boxCharTy =
-          fir::BoxCharType::get(&mlirContext, dynamicType.kind());
-      addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,
-                    dummyNameAttr(entity));
-      addPassedArg(PassEntityBy::BoxChar, entity, characteristics);
-    } else {
-      // non-PDT derived type allowed in implicit interface.
-      Fortran::common::TypeCategory cat = dynamicType.category();
-      mlir::Type type = getConverter().genType(cat, dynamicType.kind());
-      fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
-      if (!bounds.empty())
-        type = fir::SequenceType::get(bounds, type);
-      mlir::Type refType = fir::ReferenceType::get(type);
-      addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
-                    dummyNameAttr(entity));
-      addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
+    if (proc.attrs.test(
+            Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer))
+      TODO(interface.converter.getCurrentLocation(),
+           "procedure pointer arguments");
+    // Otherwise, it is a dummy procedure.
+    const Fortran::evaluate::characteristics::Procedure &procedure =
+        proc.procedure.value();
+    mlir::Type funcType =
+        getProcedureDesignatorType(&procedure, interface.converter);
+    llvm::Optional<Fortran::evaluate::DynamicType> resultTy =
+        getResultDynamicType(procedure);
+    if (resultTy && mustPassLengthWithDummyProcedure(procedure)) {
+      // The result length of dummy procedures that are character functions must
+      // be passed so that the dummy procedure can be called if it has assumed
+      // length on the callee side.
+      mlir::Type tupleType =
+          fir::factory::getCharacterProcedureTupleType(funcType);
+      llvm::StringRef charProcAttr = fir::getCharacterProcedureDummyAttrName();
+      addFirOperand(tupleType, nextPassedArgPosition(), Property::CharProcTuple,
+                    {mlir::NamedAttribute{
+                        mlir::StringAttr::get(&mlirContext, charProcAttr),
+                        mlir::UnitAttr::get(&mlirContext)}});
+      addPassedArg(PassEntityBy::CharProcTuple, entity, characteristics);
+      return;
     }
+    addFirOperand(funcType, nextPassedArgPosition(), Property::BaseAddress);
+    addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
   }
 
-  void handleImplicitDummy(
-      const DummyCharacteristics *characteristics,
-      const Fortran::evaluate::characteristics::DummyProcedure &proc,
-      const FortranEntity &entity) {
+  void handleExplicitResult(
+      const Fortran::evaluate::characteristics::FunctionResult &result) {
+    using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
+
+    if (result.IsProcedurePointer())
       TODO(interface.converter.getCurrentLocation(),
-         "handleImlicitDummy DummyProcedure");
+           "procedure pointer results");
+    const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
+        result.GetTypeAndShape();
+    assert(typeAndShape && "expect type for non proc pointer result");
+    mlir::Type mlirType = translateDynamicType(typeAndShape->type());
+    fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
+    if (!bounds.empty())
+      mlirType = fir::SequenceType::get(bounds, mlirType);
+    if (result.attrs.test(Attr::Allocatable))
+      mlirType = fir::BoxType::get(fir::HeapType::get(mlirType));
+    if (result.attrs.test(Attr::Pointer))
+      mlirType = fir::BoxType::get(fir::PointerType::get(mlirType));
+
+    if (fir::isa_char(mlirType)) {
+      // Character scalar results must be passed as arguments in lowering so
+      // that an assumed length character function callee can access the result
+      // length. A function with a result requiring an explicit interface does
+      // not have to be compatible with assumed length function, but most
+      // compilers supports it.
+      handleImplicitCharacterResult(typeAndShape->type());
+      return;
+    }
+
+    addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
+                 Property::Value);
+    // Explicit results require the caller to allocate the storage and save the
+    // function result in the storage with a fir.save_result.
+    setSaveResult();
   }
 
+  fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
+    fir::SequenceType::Shape bounds;
+    for (const std::optional<Fortran::evaluate::ExtentExpr> &extent : shape) {
+      fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent();
+      if (std::optional<std::int64_t> i = toInt64(extent))
+        bound = *i;
+      bounds.emplace_back(bound);
+    }
+    return bounds;
+  }
+  std::optional<std::int64_t>
+  toInt64(std::optional<
+          Fortran::evaluate::Expr<Fortran::evaluate::SubscriptInteger>>
+              expr) {
+    if (expr)
+      return Fortran::evaluate::ToInt64(Fortran::evaluate::Fold(
+          getConverter().getFoldingContext(), toEvExpr(*expr)));
+    return std::nullopt;
+  }
   void
   addFirOperand(mlir::Type type, int entityPosition, Property p,
                 llvm::ArrayRef<mlir::NamedAttribute> attributes = llvm::None) {
     interface.inputs.emplace_back(
         FirPlaceHolder{type, entityPosition, p, attributes});
   }
   void
   addFirResult(mlir::Type type, int entityPosition, Property p,
                llvm::ArrayRef<mlir::NamedAttribute> attributes = llvm::None) {
     interface.outputs.emplace_back(
         FirPlaceHolder{type, entityPosition, p, attributes});
   }
   void addPassedArg(PassEntityBy p, FortranEntity entity,
                     const DummyCharacteristics *characteristics) {
     interface.passedArguments.emplace_back(
-        PassedEntity{p, entity, {}, {}, characteristics});
+        PassedEntity{p, entity, emptyValue(), emptyValue(), characteristics});
   }
   void setPassedResult(PassEntityBy p, FortranEntity entity) {
     interface.passedResult =
         PassedEntity{p, entity, emptyValue(), emptyValue()};
   }
   void setSaveResult() { interface.saveResult = true; }
   int nextPassedArgPosition() { return interface.passedArguments.size(); }
 

 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);
+  // We only expect the extra host asspciations argument from the callee side as
+  // the definition of internal procedures will be present, and we'll always
+  // have a FuncOp definition in the ModuleOp, when lowering.
+  if constexpr (std::is_same_v<T, Fortran::lower::CalleeInterface>) {
+    if (side().hasHostAssociated())
+      impl.appendHostAssocTupleArg(side().getHostAssociatedTy());
+  }
 }
 
 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 <typename T>
+llvm::SmallVector<mlir::Type>
+Fortran::lower::CallInterface<T>::getResultType() const {
+  llvm::SmallVector<mlir::Type> types;
+  for (const FirPlaceHolder &out : outputs)
+    types.emplace_back(out.type);
+  return types;
+}
+
 template class Fortran::lower::CallInterface<Fortran::lower::CalleeInterface>;
 template class Fortran::lower::CallInterface<Fortran::lower::CallerInterface>;
+
+//===----------------------------------------------------------------------===//
+// Function Type Translation
+//===----------------------------------------------------------------------===//
+
+/// Build signature from characteristics when there is no Fortran entity to
+/// associate with the arguments (i.e, this is not a call site or a procedure
+/// declaration. This is needed when dealing with function pointers/dummy
+/// arguments.
+
+class SignatureBuilder;
+template <>
+struct Fortran::lower::PassedEntityTypes<SignatureBuilder> {
+  using FortranEntity = FakeEntity;
+  using FirValue = int;
+};
+
+/// SignatureBuilder is a CRTP implementation of CallInterface intended to
+/// help translating characteristics::Procedure to mlir::FunctionType using
+/// the CallInterface translation.
+class SignatureBuilder
+    : public Fortran::lower::CallInterface<SignatureBuilder> {
+public:
+  SignatureBuilder(const Fortran::evaluate::characteristics::Procedure &p,
+                   Fortran::lower::AbstractConverter &c, bool forceImplicit)
+      : CallInterface{c}, proc{p} {
+    bool isImplicit = forceImplicit || proc.CanBeCalledViaImplicitInterface();
+    determineInterface(isImplicit, proc);
+  }
+  /// Does the procedure characteristics being translated have alternate
+  /// returns ?
+  bool hasAlternateReturns() const {
+    for (const Fortran::evaluate::characteristics::DummyArgument &dummy :
+         proc.dummyArguments)
+      if (std::holds_alternative<
+              Fortran::evaluate::characteristics::AlternateReturn>(dummy.u))
+        return true;
+    return false;
+  };
+
+  /// This is only here to fulfill CRTP dependencies and should not be called.
+  std::string getMangledName() const {
+    llvm_unreachable("trying to get name from SignatureBuilder");
+  }
+
+  /// This is only here to fulfill CRTP dependencies and should not be called.
+  mlir::Location getCalleeLocation() const {
+    llvm_unreachable("trying to get callee location from SignatureBuilder");
+  }
+
+  /// This is only here to fulfill CRTP dependencies and should not be called.
+  const Fortran::semantics::Symbol *getProcedureSymbol() const {
+    llvm_unreachable("trying to get callee symbol from SignatureBuilder");
+  };
+
+  Fortran::evaluate::characteristics::Procedure characterize() const {
+    return proc;
+  }
+  /// SignatureBuilder cannot be used on main program.
+  static constexpr bool isMainProgram() { return false; }
+
+  /// Return the characteristics::Procedure that is being translated to
+  /// mlir::FunctionType.
+  const Fortran::evaluate::characteristics::Procedure &
+  getCallDescription() const {
+    return proc;
+  }
+
+  /// This is not the description of an indirect call.
+  static constexpr bool isIndirectCall() { return false; }
+
+  /// Return the translated signature.
+  mlir::FunctionType getFunctionType() { return genFunctionType(); }
+
+  // Copy of base implementation.
+  static constexpr bool hasHostAssociated() { return false; }
+  mlir::Type getHostAssociatedTy() const {
+    llvm_unreachable("getting host associated type in SignatureBuilder");
+  }
+
+private:
+  const Fortran::evaluate::characteristics::Procedure &proc;
+};
+
+mlir::FunctionType Fortran::lower::translateSignature(
+    const Fortran::evaluate::ProcedureDesignator &proc,
+    Fortran::lower::AbstractConverter &converter) {
+  std::optional<Fortran::evaluate::characteristics::Procedure> characteristics =
+      Fortran::evaluate::characteristics::Procedure::Characterize(
+          proc, converter.getFoldingContext());
+  // Most unrestricted intrinsic characteristic has the Elemental attribute
+  // which triggers CanBeCalledViaImplicitInterface to return false. However,
+  // using implicit interface rules is just fine here.
+  bool forceImplicit = proc.GetSpecificIntrinsic();
+  return SignatureBuilder{characteristics.value(), converter, forceImplicit}
+      .getFunctionType();
+}
+
+mlir::FuncOp Fortran::lower::getOrDeclareFunction(
+    llvm::StringRef name, const Fortran::evaluate::ProcedureDesignator &proc,
+    Fortran::lower::AbstractConverter &converter) {
+  mlir::ModuleOp module = converter.getModuleOp();
+  mlir::FuncOp func = fir::FirOpBuilder::getNamedFunction(module, name);
+  if (func)
+    return func;
+
+  const Fortran::semantics::Symbol *symbol = proc.GetSymbol();
+  assert(symbol && "non user function in getOrDeclareFunction");
+  // getOrDeclareFunction is only used for functions not defined in the current
+  // program unit, so use the location of the procedure designator symbol, which
+  // is the first occurrence of the procedure in the program unit.
+  mlir::Location loc = converter.genLocation(symbol->name());
+  std::optional<Fortran::evaluate::characteristics::Procedure> characteristics =
+      Fortran::evaluate::characteristics::Procedure::Characterize(
+          proc, converter.getFoldingContext());
+  mlir::FunctionType ty = SignatureBuilder{characteristics.value(), converter,
+                                           /*forceImplicit=*/false}
+                              .getFunctionType();
+  mlir::FuncOp newFunc =
+      fir::FirOpBuilder::createFunction(loc, module, name, ty);
+  addSymbolAttribute(newFunc, *symbol, converter.getMLIRContext());
+  return newFunc;
+}
+
+// Is it required to pass a dummy procedure with \p characteristics as a tuple
+// containing the function address and the result length ?
+static bool mustPassLengthWithDummyProcedure(
+    const std::optional<Fortran::evaluate::characteristics::Procedure>
+        &characteristics) {
+  return characteristics &&
+         Fortran::lower::CallInterfaceImpl<SignatureBuilder>::
+             mustPassLengthWithDummyProcedure(*characteristics);
+}
+
+bool Fortran::lower::mustPassLengthWithDummyProcedure(
+    const Fortran::evaluate::ProcedureDesignator &procedure,
+    Fortran::lower::AbstractConverter &converter) {
+  std::optional<Fortran::evaluate::characteristics::Procedure> characteristics =
+      Fortran::evaluate::characteristics::Procedure::Characterize(
+          procedure, converter.getFoldingContext());
+  return ::mustPassLengthWithDummyProcedure(characteristics);
+}
+
+mlir::Type Fortran::lower::getDummyProcedureType(
+    const Fortran::semantics::Symbol &dummyProc,
+    Fortran::lower::AbstractConverter &converter) {
+  std::optional<Fortran::evaluate::characteristics::Procedure> iface =
+      Fortran::evaluate::characteristics::Procedure::Characterize(
+          dummyProc, converter.getFoldingContext());
+  mlir::Type procType = getProcedureDesignatorType(
+      iface.has_value() ? &*iface : nullptr, converter);
+  if (::mustPassLengthWithDummyProcedure(iface))
+    return fir::factory::getCharacterProcedureTupleType(procType);
+  return procType;
+}

flang/lib/Lower/ConvertExpr.cpp

 #include "flang/Lower/DumpEvaluateExpr.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/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/Factory.h"
+#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/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/Func/IR/FuncOps.h"
 #include "llvm/Support/Debug.h"
if (caller.mustMapInterfaceSymbols()) {
       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");
+    if (const Fortran::semantics::Symbol *sym =
+            caller.getIfIndirectCallSymbol()) {
+      funcPointer = symMap.lookupSymbol(*sym).getAddr();
+      if (!funcPointer)
+        fir::emitFatalError(loc, "failed to find indirect call symbol address");
+      if (fir::isCharacterProcedureTuple(funcPointer.getType(),
+                                         /*acceptRawFunc=*/false))
+        std::tie(funcPointer, charFuncPointerLength) =
+            fir::factory::extractCharacterProcedureTuple(builder, loc,
+                                                         funcPointer);
     }
 
     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> {
             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");
+        auto *bldr = &converter.getFirOpBuilder();
+        auto stackSaveFn = fir::factory::getLlvmStackSave(builder);
+        auto stackSaveSymbol = bldr->getSymbolRefAttr(stackSaveFn.getName());
+        mlir::Value sp =
+            bldr->create<fir::CallOp>(loc, stackSaveFn.getType().getResults(),
+                                      stackSaveSymbol, mlir::ValueRange{})
+                .getResult(0);
+        stmtCtx.attachCleanup([bldr, loc, sp]() {
+          auto stackRestoreFn = fir::factory::getLlvmStackRestore(*bldr);
+          auto stackRestoreSymbol =
+              bldr->getSymbolRefAttr(stackRestoreFn.getName());
+          bldr->create<fir::CallOp>(loc, stackRestoreFn.getType().getResults(),
+                                    stackRestoreSymbol, mlir::ValueRange{sp});
+        });
       }
       mlir::Value temp =
           builder.createTemporary(loc, type, ".result", extents, resultLengths);
       return toExtendedValue(loc, temp, extents, lengths);
     }();
 
     if (mustPopSymMap)
       symMap.popScope();
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");
+              // 9.7.3.2 point 4. Finalize allocatables.
+              fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
+              stmtCtx.attachCleanup([bldr, loc, box]() {
+                fir::factory::genFinalization(*bldr, loc, box);
+              });
             }
           },
           [](const auto &) {});
       return *allocatedResult;
     }
 
     if (!resultType.hasValue())
       return mlir::Value{}; // subroutine call

flang/lib/Lower/ConvertVariable.cpp

ba.match(
         }
         mlir::Value local = createNewLocal(converter, loc, var, preAlloc);
         symMap.addCharSymbol(sym, local, len);
       },
 
       //===--------------------------------------------------------------===//
 
       [&](const Fortran::lower::details::ScalarDynamicChar &x) {
-        TODO(loc, "ScalarDynamicChar variable lowering");
+        // type is a CHARACTER, determine the LEN value
+        auto charLen = x.charLen();
+        if (replace) {
+          Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(sym);
+          mlir::Value boxAddr = symBox.getAddr();
+          mlir::Value len;
+          mlir::Type addrTy = boxAddr.getType();
+          if (addrTy.isa<fir::BoxCharType>() || addrTy.isa<fir::BoxType>()) {
+            std::tie(boxAddr, len) = charHelp.createUnboxChar(symBox.getAddr());
+          } else {
+            // dummy from an other entry case: we cannot get a dynamic length
+            // for it, it's illegal for the user program to use it. However,
+            // since we are lowering all function unit statements regardless
+            // of whether the execution will reach them or not, we need to
+            // fill a value for the length here.
+            len = builder.createIntegerConstant(
+                loc, builder.getCharacterLengthType(), 1);
+          }
+          // Override LEN with an expression
+          if (charLen)
+            len = genExplicitCharLen(charLen);
+          symMap.addCharSymbol(sym, boxAddr, len, true);
+          return;
+        }
+        // local CHARACTER variable
+        mlir::Value len = genExplicitCharLen(charLen);
+        if (preAlloc) {
+          symMap.addCharSymbol(sym, preAlloc, len);
+          return;
+        }
+        llvm::SmallVector<mlir::Value> lengths = {len};
+        mlir::Value local =
+            createNewLocal(converter, loc, var, preAlloc, llvm::None, lengths);
+        symMap.addCharSymbol(sym, local, len);
       },
 
       //===--------------------------------------------------------------===//
 
       [&](const Fortran::lower::details::StaticArray &x) {
         // object shape is constant, not a character
         mlir::Type castTy = builder.getRefType(converter.genType(var));
         mlir::Value addr = symMap.lookupSymbol(sym).getAddr();

flang/lib/Lower/HostAssociations.cpp

+//===-- HostAssociations.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/HostAssociations.h"
+#include "flang/Evaluate/check-expression.h"
+#include "flang/Lower/AbstractConverter.h"
+#include "flang/Lower/Allocatable.h"
+#include "flang/Lower/BoxAnalyzer.h"
+#include "flang/Lower/CallInterface.h"
+#include "flang/Lower/ConvertType.h"
+#include "flang/Lower/PFTBuilder.h"
+#include "flang/Lower/SymbolMap.h"
+#include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/Character.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+#include "flang/Optimizer/Support/FatalError.h"
+#include "flang/Semantics/tools.h"
+#include "llvm/ADT/TypeSwitch.h"
+#include "llvm/Support/Debug.h"
+
+#define DEBUG_TYPE "flang-host-assoc"
+
+// Host association inside internal procedures is implemented by allocating an
+// mlir tuple (a struct) inside the host containing the addresses and properties
+// of variables that are accessed by internal procedures. The address of this
+// tuple is passed as an argument by the host when calling internal procedures.
+// Internal procedures propagate a reference to this tuple when calling other
+// internal procedures of the host.
+//
+// This file defines how the type of the host tuple is built, how the tuple
+// value is created inside the host, and how the host associated variables are
+// instantiated inside the internal procedures from the tuple value. The
+// CapturedXXX classes define each of these three actions for a specific
+// kind of variables by providing a `getType`, a `instantiateHostTuple`, and a
+// `getFromTuple` method. These classes are structured as follow:
+//
+//   class CapturedKindOfVar : public CapturedSymbols<CapturedKindOfVar> {
+//     // Return the type of the tuple element for a host associated
+//     // variable given its symbol inside the host. This is called when
+//     // building function interfaces.
+//     static mlir::Type getType();
+//     // Build the tuple element value for a host associated variable given its
+//     // value inside the host. This is called when lowering the host body.
+//     static void instantiateHostTuple();
+//     // Instantiate a host variable inside an internal procedure given its
+//     // tuple element value. This is called when lowering internal procedure
+//     // bodies.
+//     static void getFromTuple();
+//   };
+//
+// If a new kind of variable requires ad-hoc handling, a new CapturedXXX class
+// should be added to handle it, and `walkCaptureCategories` should be updated
+// to dispatch this new kind of variable to this new class.
+
+/// Struct to be used as argument in walkCaptureCategories when building the
+/// tuple element type for a host associated variable.
+struct GetTypeInTuple {
+  /// walkCaptureCategories must return a type.
+  using Result = mlir::Type;
+};
+
+/// Struct to be used as argument in walkCaptureCategories when building the
+/// tuple element value for a host associated variable.
+struct InstantiateHostTuple {
+  /// walkCaptureCategories returns nothing.
+  using Result = void;
+  /// Value of the variable inside the host procedure.
+  fir::ExtendedValue hostValue;
+  /// Address of the tuple element of the variable.
+  mlir::Value addrInTuple;
+  mlir::Location loc;
+};
+
+/// Struct to be used as argument in walkCaptureCategories when instantiating a
+/// host associated variables from its tuple element value.
+struct GetFromTuple {
+  /// walkCaptureCategories returns nothing.
+  using Result = void;
+  /// Symbol map inside the internal procedure.
+  Fortran::lower::SymMap &symMap;
+  /// Value of the tuple element for the host associated variable.
+  mlir::Value valueInTuple;
+  mlir::Location loc;
+};
+
+/// Base class that must be inherited with CRTP by classes defining
+/// how host association is implemented for a type of symbol.
+/// It simply dispatches visit() calls to the implementations according
+/// to the argument type.
+template <typename SymbolCategory>
+class CapturedSymbols {
+public:
+  template <typename T>
+  static void visit(const T &, Fortran::lower::AbstractConverter &,
+                    const Fortran::semantics::Symbol &,
+                    const Fortran::lower::BoxAnalyzer &) {
+    static_assert(!std::is_same_v<T, T> &&
+                  "default visit must not be instantiated");
+  }
+  static mlir::Type visit(const GetTypeInTuple &,
+                          Fortran::lower::AbstractConverter &converter,
+                          const Fortran::semantics::Symbol &sym,
+                          const Fortran::lower::BoxAnalyzer &) {
+    return SymbolCategory::getType(converter, sym);
+  }
+  static void visit(const InstantiateHostTuple &args,
+                    Fortran::lower::AbstractConverter &converter,
+                    const Fortran::semantics::Symbol &sym,
+                    const Fortran::lower::BoxAnalyzer &) {
+    return SymbolCategory::instantiateHostTuple(args, converter, sym);
+  }
+  static void visit(const GetFromTuple &args,
+                    Fortran::lower::AbstractConverter &converter,
+                    const Fortran::semantics::Symbol &sym,
+                    const Fortran::lower::BoxAnalyzer &ba) {
+    return SymbolCategory::getFromTuple(args, converter, sym, ba);
+  }
+};
+
+/// Class defining simple scalars are captured in internal procedures.
+/// Simple scalars are non character intrinsic scalars. They are captured
+/// as `!fir.ref<T>`, for example `!fir.ref<i32>` for `INTEGER*4`.
+class CapturedSimpleScalars : public CapturedSymbols<CapturedSimpleScalars> {
+public:
+  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
+                            const Fortran::semantics::Symbol &sym) {
+    return fir::ReferenceType::get(converter.genType(sym));
+  }
+
+  static void instantiateHostTuple(const InstantiateHostTuple &args,
+                                   Fortran::lower::AbstractConverter &converter,
+                                   const Fortran::semantics::Symbol &) {
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
+    assert(typeInTuple && "addrInTuple must be an address");
+    mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
+                                                fir::getBase(args.hostValue));
+    builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
+  }
+
+  static void getFromTuple(const GetFromTuple &args,
+                           Fortran::lower::AbstractConverter &,
+                           const Fortran::semantics::Symbol &sym,
+                           const Fortran::lower::BoxAnalyzer &) {
+    args.symMap.addSymbol(sym, args.valueInTuple);
+  }
+};
+
+/// Class defining how dummy procedures and procedure pointers
+/// are captured in internal procedures.
+class CapturedProcedure : public CapturedSymbols<CapturedProcedure> {
+public:
+  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
+                            const Fortran::semantics::Symbol &sym) {
+    if (Fortran::semantics::IsPointer(sym))
+      TODO(converter.getCurrentLocation(),
+           "capture procedure pointer in internal procedure");
+    return Fortran::lower::getDummyProcedureType(sym, converter);
+  }
+
+  static void instantiateHostTuple(const InstantiateHostTuple &args,
+                                   Fortran::lower::AbstractConverter &converter,
+                                   const Fortran::semantics::Symbol &) {
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
+    assert(typeInTuple && "addrInTuple must be an address");
+    mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
+                                                fir::getBase(args.hostValue));
+    builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
+  }
+
+  static void getFromTuple(const GetFromTuple &args,
+                           Fortran::lower::AbstractConverter &,
+                           const Fortran::semantics::Symbol &sym,
+                           const Fortran::lower::BoxAnalyzer &) {
+    args.symMap.addSymbol(sym, args.valueInTuple);
+  }
+};
+
+/// Class defining how character scalars are captured in internal procedures.
+/// Character scalars are passed as !fir.boxchar<kind> in the tuple.
+class CapturedCharacterScalars
+    : public CapturedSymbols<CapturedCharacterScalars> {
+public:
+  // Note: so far, do not specialize constant length characters. They can be
+  // implemented by only passing the address. This could be done later in
+  // lowering or a CapturedStaticLenCharacterScalars class could be added here.
+
+  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
+                            const Fortran::semantics::Symbol &sym) {
+    fir::KindTy kind =
+        converter.genType(sym).cast<fir::CharacterType>().getFKind();
+    return fir::BoxCharType::get(&converter.getMLIRContext(), kind);
+  }
+
+  static void instantiateHostTuple(const InstantiateHostTuple &args,
+                                   Fortran::lower::AbstractConverter &converter,
+                                   const Fortran::semantics::Symbol &) {
+    const fir::CharBoxValue *charBox = args.hostValue.getCharBox();
+    assert(charBox && "host value must be a fir::CharBoxValue");
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    mlir::Value boxchar = fir::factory::CharacterExprHelper(builder, args.loc)
+                              .createEmbox(*charBox);
+    builder.create<fir::StoreOp>(args.loc, boxchar, args.addrInTuple);
+  }
+
+  static void getFromTuple(const GetFromTuple &args,
+                           Fortran::lower::AbstractConverter &converter,
+                           const Fortran::semantics::Symbol &sym,
+                           const Fortran::lower::BoxAnalyzer &) {
+    fir::factory::CharacterExprHelper charHelp(converter.getFirOpBuilder(),
+                                               args.loc);
+    std::pair<mlir::Value, mlir::Value> unboxchar =
+        charHelp.createUnboxChar(args.valueInTuple);
+    args.symMap.addCharSymbol(sym, unboxchar.first, unboxchar.second);
+  }
+};
+
+/// Is \p sym a derived type entity with length parameters ?
+static bool
+isDerivedWithLengthParameters(const Fortran::semantics::Symbol &sym) {
+  if (const auto *declTy = sym.GetType())
+    if (const auto *derived = declTy->AsDerived())
+      return Fortran::semantics::CountLenParameters(*derived) != 0;
+  return false;
+}
+
+/// Class defining how allocatable and pointers entities are captured in
+/// internal procedures. Allocatable and pointers are simply captured by placing
+/// their !fir.ref<fir.box<>> address in the host tuple.
+class CapturedAllocatableAndPointer
+    : public CapturedSymbols<CapturedAllocatableAndPointer> {
+public:
+  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
+                            const Fortran::semantics::Symbol &sym) {
+    return fir::ReferenceType::get(converter.genType(sym));
+  }
+  static void instantiateHostTuple(const InstantiateHostTuple &args,
+                                   Fortran::lower::AbstractConverter &converter,
+                                   const Fortran::semantics::Symbol &) {
+    assert(args.hostValue.getBoxOf<fir::MutableBoxValue>() &&
+           "host value must be a fir::MutableBoxValue");
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
+    assert(typeInTuple && "addrInTuple must be an address");
+    mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
+                                                fir::getBase(args.hostValue));
+    builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
+  }
+  static void getFromTuple(const GetFromTuple &args,
+                           Fortran::lower::AbstractConverter &converter,
+                           const Fortran::semantics::Symbol &sym,
+                           const Fortran::lower::BoxAnalyzer &ba) {
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    mlir::Location loc = args.loc;
+    // Non deferred type parameters impact the semantics of some statements
+    // where allocatables/pointer can appear. For instance, assignment to a
+    // scalar character allocatable with has a different semantics in F2003 and
+    // later if the length is non deferred vs when it is deferred. So it is
+    // important to keep track of the non deferred parameters here.
+    llvm::SmallVector<mlir::Value> nonDeferredLenParams;
+    if (ba.isChar()) {
+      mlir::IndexType idxTy = builder.getIndexType();
+      if (llvm::Optional<int64_t> len = ba.getCharLenConst()) {
+        nonDeferredLenParams.push_back(
+            builder.createIntegerConstant(loc, idxTy, *len));
+      } else if (Fortran::semantics::IsAssumedLengthCharacter(sym) ||
+                 ba.getCharLenExpr()) {
+        // Read length from fir.box (explicit expr cannot safely be re-evaluated
+        // here).
+        auto readLength = [&]() {
+          fir::BoxValue boxLoad =
+              builder.create<fir::LoadOp>(loc, fir::getBase(args.valueInTuple))
+                  .getResult();
+          return fir::factory::readCharLen(builder, loc, boxLoad);
+        };
+        if (Fortran::semantics::IsOptional(sym)) {
+          // It is not safe to unconditionally read boxes of optionals in case
+          // they are absents. According to 15.5.2.12 3 (9), it is illegal to
+          // inquire the length of absent optional, even if non deferred, so
+          // it's fine to use undefOp in this case.
+          auto isPresent = builder.create<fir::IsPresentOp>(
+              loc, builder.getI1Type(), fir::getBase(args.valueInTuple));
+          mlir::Value len =
+              builder.genIfOp(loc, {idxTy}, isPresent, true)
+                  .genThen([&]() {
+                    builder.create<fir::ResultOp>(loc, readLength());
+                  })
+                  .genElse([&]() {
+                    auto undef = builder.create<fir::UndefOp>(loc, idxTy);
+                    builder.create<fir::ResultOp>(loc, undef.getResult());
+                  })
+                  .getResults()[0];
+          nonDeferredLenParams.push_back(len);
+        } else {
+          nonDeferredLenParams.push_back(readLength());
+        }
+      }
+    } else if (isDerivedWithLengthParameters(sym)) {
+      TODO(loc, "host associated derived type allocatable or pointer with "
+                "length parameters");
+    }
+    args.symMap.addSymbol(
+        sym, fir::MutableBoxValue(args.valueInTuple, nonDeferredLenParams, {}));
+  }
+};
+
+/// Class defining how arrays are captured inside internal procedures.
+/// Array are captured via a `fir.box<fir.array<T>>` descriptor that belongs to
+/// the host tuple. This allows capturing lower bounds, which can be done by
+/// providing a ShapeShiftOp argument to the EmboxOp.
+class CapturedArrays : public CapturedSymbols<CapturedArrays> {
+
+  // Note: Constant shape arrays are not specialized (their base address would
+  // be sufficient information inside the tuple). They could be specialized in
+  // a later FIR pass, or a CapturedStaticShapeArrays could be added to deal
+  // with them here.
+public:
+  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
+                            const Fortran::semantics::Symbol &sym) {
+    mlir::Type type = converter.genType(sym);
+    assert(type.isa<fir::SequenceType>() && "must be a sequence type");
+    return fir::BoxType::get(type);
+  }
+
+  static void instantiateHostTuple(const InstantiateHostTuple &args,
+                                   Fortran::lower::AbstractConverter &converter,
+                                   const Fortran::semantics::Symbol &sym) {
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    mlir::Location loc = args.loc;
+    fir::MutableBoxValue boxInTuple(args.addrInTuple, {}, {});
+    if (args.hostValue.getBoxOf<fir::BoxValue>() &&
+        Fortran::semantics::IsOptional(sym)) {
+      // The assumed shape optional case need some care because it is illegal to
+      // read the incoming box if it is absent (this would cause segfaults).
+      // Pointer association requires reading the target box, so it can only be
+      // done on present optional. For absent optionals, simply create a
+      // disassociated pointer (it is illegal to inquire about lower bounds or
+      // lengths of optional according to 15.5.2.12 3 (9) and 10.1.11 2 (7)b).
+      auto isPresent = builder.create<fir::IsPresentOp>(
+          loc, builder.getI1Type(), fir::getBase(args.hostValue));
+      builder.genIfThenElse(loc, isPresent)
+          .genThen([&]() {
+            fir::factory::associateMutableBox(builder, loc, boxInTuple,
+                                              args.hostValue,
+                                              /*lbounds=*/llvm::None);
+          })
+          .genElse([&]() {
+            fir::factory::disassociateMutableBox(builder, loc, boxInTuple);
+          })
+          .end();
+    } else {
+      fir::factory::associateMutableBox(builder, loc, boxInTuple,
+                                        args.hostValue, /*lbounds=*/llvm::None);
+    }
+  }
+
+  static void getFromTuple(const GetFromTuple &args,
+                           Fortran::lower::AbstractConverter &converter,
+                           const Fortran::semantics::Symbol &sym,
+                           const Fortran::lower::BoxAnalyzer &ba) {
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    mlir::Location loc = args.loc;
+    mlir::Value box = args.valueInTuple;
+    mlir::IndexType idxTy = builder.getIndexType();
+    llvm::SmallVector<mlir::Value> lbounds;
+    if (!ba.lboundIsAllOnes()) {
+      if (ba.isStaticArray()) {
+        for (std::int64_t lb : ba.staticLBound())
+          lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
+      } else {
+        // Cannot re-evaluate specification expressions here.
+        // Operands values may have changed. Get value from fir.box
+        const unsigned rank = sym.Rank();
+        for (unsigned dim = 0; dim < rank; ++dim) {
+          mlir::Value dimVal = builder.createIntegerConstant(loc, idxTy, dim);
+          auto dims = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
+                                                     box, dimVal);
+          lbounds.emplace_back(dims.getResult(0));
+        }
+      }
+    }
+
+    if (canReadCapturedBoxValue(converter, sym)) {
+      fir::BoxValue boxValue(box, lbounds, /*explicitParams=*/llvm::None);
+      args.symMap.addSymbol(sym,
+                            fir::factory::readBoxValue(builder, loc, boxValue));
+    } else {
+      // Keep variable as a fir.box.
+      // If this is an optional that is absent, the fir.box needs to be an
+      // AbsentOp result, otherwise it will not work properly with IsPresentOp
+      // (absent boxes are null descriptor addresses, not descriptors containing
+      // a null base address).
+      if (Fortran::semantics::IsOptional(sym)) {
+        auto boxTy = box.getType().cast<fir::BoxType>();
+        auto eleTy = boxTy.getEleTy();
+        if (!fir::isa_ref_type(eleTy))
+          eleTy = builder.getRefType(eleTy);
+        auto addr = builder.create<fir::BoxAddrOp>(loc, eleTy, box);
+        mlir::Value isPresent = builder.genIsNotNull(loc, addr);
+        auto absentBox = builder.create<fir::AbsentOp>(loc, boxTy);
+        box = builder.create<mlir::arith::SelectOp>(loc, isPresent, box,
+                                                    absentBox);
+      }
+      fir::BoxValue boxValue(box, lbounds, /*explicitParams=*/llvm::None);
+      args.symMap.addSymbol(sym, boxValue);
+    }
+  }
+
+private:
+  /// Can the fir.box from the host link be read into simpler values ?
+  /// Later, without the symbol information, it might not be possible
+  /// to tell if the fir::BoxValue from the host link is contiguous.
+  static bool
+  canReadCapturedBoxValue(Fortran::lower::AbstractConverter &converter,
+                          const Fortran::semantics::Symbol &sym) {
+    bool isScalarOrContiguous =
+        sym.Rank() == 0 || Fortran::evaluate::IsSimplyContiguous(
+                               Fortran::evaluate::AsGenericExpr(sym).value(),
+                               converter.getFoldingContext());
+    const Fortran::semantics::DeclTypeSpec *type = sym.GetType();
+    bool isPolymorphic = type && type->IsPolymorphic();
+    return isScalarOrContiguous && !isPolymorphic &&
+           !isDerivedWithLengthParameters(sym);
+  }
+};
+
+/// Dispatch \p visitor to the CapturedSymbols which is handling how host
+/// association is implemented for this kind of symbols. This ensures the same
+/// dispatch decision is taken when building the tuple type, when creating the
+/// tuple, and when instantiating host associated variables from it.
+template <typename T>
+typename T::Result
+walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
+                      const Fortran::semantics::Symbol &sym) {
+  if (isDerivedWithLengthParameters(sym))
+    // Should be boxed.
+    TODO(converter.genLocation(sym.name()),
+         "host associated derived type with length parameters");
+  Fortran::lower::BoxAnalyzer ba;
+  // Do not analyze procedures, they may be subroutines with no types that would
+  // crash the analysis.
+  if (Fortran::semantics::IsProcedure(sym))
+    return CapturedProcedure::visit(visitor, converter, sym, ba);
+  ba.analyze(sym);
+  if (Fortran::evaluate::IsAllocatableOrPointer(sym))
+    return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
+  if (ba.isArray())
+    return CapturedArrays::visit(visitor, converter, sym, ba);
+  if (ba.isChar())
+    return CapturedCharacterScalars::visit(visitor, converter, sym, ba);
+  assert(ba.isTrivial() && "must be trivial scalar");
+  return CapturedSimpleScalars::visit(visitor, converter, sym, ba);
+}
+
+// `t` should be the result of getArgumentType, which has a type of
+// `!fir.ref<tuple<...>>`.
+static mlir::TupleType unwrapTupleTy(mlir::Type t) {
+  return fir::dyn_cast_ptrEleTy(t).cast<mlir::TupleType>();
+}
+
+static mlir::Value genTupleCoor(fir::FirOpBuilder &builder, mlir::Location loc,
+                                mlir::Type varTy, mlir::Value tupleArg,
+                                mlir::Value offset) {
+  // fir.ref<fir.ref> and fir.ptr<fir.ref> are forbidden. Use
+  // fir.llvm_ptr if needed.
+  auto ty = varTy.isa<fir::ReferenceType>()
+                ? mlir::Type(fir::LLVMPointerType::get(varTy))
+                : mlir::Type(builder.getRefType(varTy));
+  return builder.create<fir::CoordinateOp>(loc, ty, tupleArg, offset);
+}
+
+void Fortran::lower::HostAssociations::hostProcedureBindings(
+    Fortran::lower::AbstractConverter &converter,
+    Fortran::lower::SymMap &symMap) {
+  if (symbols.empty())
+    return;
+
+  // Create the tuple variable.
+  mlir::TupleType tupTy = unwrapTupleTy(getArgumentType(converter));
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::Location loc = converter.getCurrentLocation();
+  auto hostTuple = builder.create<fir::AllocaOp>(loc, tupTy);
+  mlir::IntegerType offTy = builder.getIntegerType(32);
+
+  // Walk the list of symbols and update the pointers in the tuple.
+  for (auto s : llvm::enumerate(symbols)) {
+    auto indexInTuple = s.index();
+    mlir::Value off = builder.createIntegerConstant(loc, offTy, indexInTuple);
+    mlir::Type varTy = tupTy.getType(indexInTuple);
+    mlir::Value eleOff = genTupleCoor(builder, loc, varTy, hostTuple, off);
+    InstantiateHostTuple instantiateHostTuple{
+        symMap.lookupSymbol(s.value()).toExtendedValue(), eleOff, loc};
+    walkCaptureCategories(instantiateHostTuple, converter, *s.value());
+  }
+
+  converter.bindHostAssocTuple(hostTuple);
+}
+
+void Fortran::lower::HostAssociations::internalProcedureBindings(
+    Fortran::lower::AbstractConverter &converter,
+    Fortran::lower::SymMap &symMap) {
+  if (symbols.empty())
+    return;
+
+  // Find the argument with the tuple type. The argument ought to be appended.
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  mlir::Type argTy = getArgumentType(converter);
+  mlir::TupleType tupTy = unwrapTupleTy(argTy);
+  mlir::Location loc = converter.getCurrentLocation();
+  mlir::FuncOp func = builder.getFunction();
+  mlir::Value tupleArg;
+  for (auto [ty, arg] : llvm::reverse(
+           llvm::zip(func.getType().getInputs(), func.front().getArguments())))
+    if (ty == argTy) {
+      tupleArg = arg;
+      break;
+    }
+  if (!tupleArg)
+    fir::emitFatalError(loc, "no host association argument found");
+
+  converter.bindHostAssocTuple(tupleArg);
+
+  mlir::IntegerType offTy = builder.getIntegerType(32);
+
+  // Walk the list and add the bindings to the symbol table.
+  for (auto s : llvm::enumerate(symbols)) {
+    mlir::Value off = builder.createIntegerConstant(loc, offTy, s.index());
+    mlir::Type varTy = tupTy.getType(s.index());
+    mlir::Value eleOff = genTupleCoor(builder, loc, varTy, tupleArg, off);
+    mlir::Value valueInTuple = builder.create<fir::LoadOp>(loc, eleOff);
+    GetFromTuple getFromTuple{symMap, valueInTuple, loc};
+    walkCaptureCategories(getFromTuple, converter, *s.value());
+  }
+}
+
+mlir::Type Fortran::lower::HostAssociations::getArgumentType(
+    Fortran::lower::AbstractConverter &converter) {
+  if (symbols.empty())
+    return {};
+  if (argType)
+    return argType;
+
+  // Walk the list of Symbols and create their types. Wrap them in a reference
+  // to a tuple.
+  mlir::MLIRContext *ctxt = &converter.getMLIRContext();
+  llvm::SmallVector<mlir::Type> tupleTys;
+  for (const Fortran::semantics::Symbol *sym : symbols)
+    tupleTys.emplace_back(
+        walkCaptureCategories(GetTypeInTuple{}, converter, *sym));
+  argType = fir::ReferenceType::get(mlir::TupleType::get(ctxt, tupleTys));
+  return argType;
+}

flang/lib/Optimizer/Builder/BoxValue.cpp

llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os,
   exv.match([&](const auto &value) { os << value; });
   return os;
 }
 
 /// Debug verifier for MutableBox ctor. There is no guarantee that this will
 /// always be called, so it should not have any functional side effects,
 /// the const is here to enforce that.
 bool fir::MutableBoxValue::verify() const {
-  auto type = fir::dyn_cast_ptrEleTy(getAddr().getType());
+  mlir::Type type = fir::dyn_cast_ptrEleTy(getAddr().getType());
   if (!type)
     return false;
   auto box = type.dyn_cast<fir::BoxType>();
   if (!box)
     return false;
-  auto eleTy = box.getEleTy();
-  if (!eleTy.isa<fir::PointerType>() && !eleTy.isa<fir::HeapType>())
-    return false;
+  // A boxed value always takes a memory reference,
 
   auto nParams = lenParams.size();
   if (isCharacter()) {
     if (nParams > 1)
       return false;
   } else if (!isDerived()) {
     if (nParams != 0)
       return false;

flang/lib/Optimizer/Builder/CMakeLists.txt

 get_property(dialect_libs GLOBAL PROPERTY MLIR_DIALECT_LIBS)
 
 add_flang_library(FIRBuilder
   BoxValue.cpp
   Character.cpp
   Complex.cpp
   DoLoopHelper.cpp
   FIRBuilder.cpp
+  LowLevelIntrinsics.cpp
   MutableBox.cpp
   Runtime/Assign.cpp
   Runtime/Character.cpp
   Runtime/Command.cpp
   Runtime/Derived.cpp
   Runtime/Numeric.cpp
   Runtime/Ragged.cpp
   Runtime/Reduction.cpp

flang/lib/Optimizer/Builder/LowLevelIntrinsics.cpp

+//===-- LowLevelIntrinsics.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/
+//
+//===----------------------------------------------------------------------===//
+//
+// Low level intrinsic functions.
+//
+// These include LLVM intrinsic calls and standard C library calls.
+// Target-specific calls, such as OS functions, should be factored in other
+// file(s).
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
+
+mlir::FuncOp fir::factory::getLlvmStackSave(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  auto funcTy =
+      mlir::FunctionType::get(builder.getContext(), llvm::None, {ptrTy});
+  return builder.addNamedFunction(builder.getUnknownLoc(), "llvm.stacksave",
+                                  funcTy);
+}
+
+mlir::FuncOp fir::factory::getLlvmStackRestore(fir::FirOpBuilder &builder) {
+  auto ptrTy = builder.getRefType(builder.getIntegerType(8));
+  auto funcTy =
+      mlir::FunctionType::get(builder.getContext(), {ptrTy}, llvm::None);
+  return builder.addNamedFunction(builder.getUnknownLoc(), "llvm.stackrestore",
+                                  funcTy);
+}

flang/lib/Optimizer/Dialect/FIRType.cpp

if (!(fir::isa_real(eleTy) || fir::isa_integer(eleTy)))
     return emitError() << "cannot build a vector of type " << eleTy << '\n';
   return mlir::success();
 }
 
 bool fir::VectorType::isValidElementType(mlir::Type t) {
   return isa_real(t) || isa_integer(t);
 }
 
+bool fir::isCharacterProcedureTuple(mlir::Type ty, bool acceptRawFunc) {
+  mlir::TupleType tuple = ty.dyn_cast<mlir::TupleType>();
+  return tuple && tuple.size() == 2 &&
+         (tuple.getType(0).isa<fir::BoxProcType>() ||
+          (acceptRawFunc && tuple.getType(0).isa<mlir::FunctionType>())) &&
+         fir::isa_integer(tuple.getType(1));
+}
+
 //===----------------------------------------------------------------------===//
 // FIROpsDialect
 //===----------------------------------------------------------------------===//
 
 void FIROpsDialect::registerTypes() {
   addTypes<BoxType, BoxCharType, BoxProcType, CharacterType, fir::ComplexType,
            FieldType, HeapType, fir::IntegerType, LenType, LogicalType,
            LLVMPointerType, PointerType, RealType, RecordType, ReferenceType,
            SequenceType, ShapeType, ShapeShiftType, ShiftType, SliceType,
            TypeDescType, fir::VectorType>();
 }

flang/test/Lower/host-associated.f90

+! Test internal procedure host association lowering.
+! RUN: bbc %s -o - -emit-fir | FileCheck %s
+
+! -----------------------------------------------------------------------------
+!     Test non character intrinsic scalars
+! -----------------------------------------------------------------------------
+
+!!! Test scalar (with implicit none)
+
+! CHECK-LABEL: func @_QPtest1(
+subroutine test1
+  implicit none
+  integer i
+  ! CHECK-DAG: %[[i:.*]] = fir.alloca i32 {{.*}}uniq_name = "_QFtest1Ei"
+  ! CHECK-DAG: %[[tup:.*]] = fir.alloca tuple<!fir.ref<i32>>
+  ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[tup]], %c0
+  ! CHECK: fir.store %[[i]] to %[[addr]] : !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK: fir.call @_QFtest1Ptest1_internal(%[[tup]]) : (!fir.ref<tuple<!fir.ref<i32>>>) -> ()
+  call test1_internal
+  print *, i
+contains
+  ! CHECK-LABEL: func @_QFtest1Ptest1_internal(
+  ! CHECK-SAME: %[[arg:[^:]*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) {
+  ! CHECK: %[[iaddr:.*]] = fir.coordinate_of %[[arg]], %c0
+  ! CHECK: %[[i:.*]] = fir.load %[[iaddr]] : !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK: %[[val:.*]] = fir.call @_QPifoo() : () -> i32
+  ! CHECK: fir.store %[[val]] to %[[i]] : !fir.ref<i32>
+  subroutine test1_internal
+    integer, external :: ifoo
+    i = ifoo()
+  end subroutine test1_internal
+end subroutine test1
+
+!!! Test scalar
+
+! CHECK-LABEL: func @_QPtest2() {
+subroutine test2
+  a = 1.0
+  b = 2.0
+  ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.ref<f32>, !fir.ref<f32>>
+  ! CHECK: %[[a0:.*]] = fir.coordinate_of %[[tup]], %c0
+  ! CHECK: fir.store %{{.*}} to %[[a0]] : !fir.llvm_ptr<!fir.ref<f32>>
+  ! CHECK: %[[b0:.*]] = fir.coordinate_of %[[tup]], %c1
+  ! CHECK: fir.store %{{.*}} to %[[b0]] : !fir.llvm_ptr<!fir.ref<f32>>
+  ! CHECK: fir.call @_QFtest2Ptest2_internal(%[[tup]]) : (!fir.ref<tuple<!fir.ref<f32>, !fir.ref<f32>>>) -> ()
+  call test2_internal
+  print *, a, b
+contains
+  ! CHECK-LABEL: func @_QFtest2Ptest2_internal(
+  ! CHECK-SAME: %[[arg:[^:]*]]: !fir.ref<tuple<!fir.ref<f32>, !fir.ref<f32>>> {fir.host_assoc}) {
+  subroutine test2_internal
+    ! CHECK: %[[a:.*]] = fir.coordinate_of %[[arg]], %c0
+    ! CHECK: %[[aa:.*]] = fir.load %[[a]] : !fir.llvm_ptr<!fir.ref<f32>>
+    ! CHECK: %[[b:.*]] = fir.coordinate_of %[[arg]], %c1
+    ! CHECK: %{{.*}} = fir.load %[[b]] : !fir.llvm_ptr<!fir.ref<f32>>
+    ! CHECK: fir.alloca
+    ! CHECK: fir.load %[[aa]] : !fir.ref<f32>
+    c = a
+    a = b
+    b = c
+    call test2_inner
+  end subroutine test2_internal
+
+  ! CHECK-LABEL: func @_QFtest2Ptest2_inner(
+  ! CHECK-SAME: %[[arg:[^:]*]]: !fir.ref<tuple<!fir.ref<f32>, !fir.ref<f32>>> {fir.host_assoc}) {
+  subroutine test2_inner
+    ! CHECK: %[[a:.*]] = fir.coordinate_of %[[arg]], %c0
+    ! CHECK: %[[aa:.*]] = fir.load %[[a]] : !fir.llvm_ptr<!fir.ref<f32>>
+    ! CHECK: %[[b:.*]] = fir.coordinate_of %[[arg]], %c1
+    ! CHECK: %[[bb:.*]] = fir.load %[[b]] : !fir.llvm_ptr<!fir.ref<f32>>
+    ! CHECK-DAG: %[[bd:.*]] = fir.load %[[bb]] : !fir.ref<f32>
+    ! CHECK-DAG: %[[ad:.*]] = fir.load %[[aa]] : !fir.ref<f32>
+    ! CHECK: %{{.*}} = arith.cmpf ogt, %[[ad]], %[[bd]] : f32
+    if (a > b) then
+       b = b + 2.0
+    end if
+  end subroutine test2_inner
+end subroutine test2
+
+! -----------------------------------------------------------------------------
+!     Test non character scalars
+! -----------------------------------------------------------------------------
+
+! CHECK-LABEL: func @_QPtest6(
+! CHECK-SAME: %[[c:.*]]: !fir.boxchar<1>
+subroutine test6(c)
+  character(*) :: c
+  ! CHECK: %[[cunbox:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+  ! CHECK: %[[tup:.*]] = fir.alloca tuple<!fir.boxchar<1>>
+  ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
+  ! CHECK: %[[emboxchar:.*]] = fir.emboxchar %[[cunbox]]#0, %[[cunbox]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+  ! CHECK: fir.store %[[emboxchar]] to %[[coor]] : !fir.ref<!fir.boxchar<1>>
+  ! CHECK: fir.call @_QFtest6Ptest6_inner(%[[tup]]) : (!fir.ref<tuple<!fir.boxchar<1>>>) -> ()
+  call test6_inner
+  print *, c
+
+contains
+  ! CHECK-LABEL: func @_QFtest6Ptest6_inner(
+  ! CHECK-SAME: %[[tup:.*]]: !fir.ref<tuple<!fir.boxchar<1>>> {fir.host_assoc}) {
+  subroutine test6_inner
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[tup]], %c0{{.*}} : (!fir.ref<tuple<!fir.boxchar<1>>>, i32) -> !fir.ref<!fir.boxchar<1>>
+    ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.boxchar<1>>
+    ! CHECK: fir.unboxchar %[[load]] : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
+    c = "Hi there"
+  end subroutine test6_inner
+end subroutine test6