Implement procedure components & theirs assignment (wip)

flang/include/flang/Lower/CallInterface.h

 // or subroutine.
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_LOWER_CALLINTERFACE_H
 #define FORTRAN_LOWER_CALLINTERFACE_H
 
 #include "flang/Common/reference.h"
 #include "flang/Evaluate/characteristics.h"
+#include "flang/Semantics/symbol.h"
 #include "mlir/Dialect/Func/IR/FuncOps.h"
 #include "mlir/IR/BuiltinOps.h"
 #include <memory>
 #include <optional>
 
 namespace Fortran::semantics {
 class Symbol;
 }

 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 &);
+mlir::FunctionType
+translateSignature(const semantics::Symbol &procedure,
+                   Fortran::lower::AbstractConverter &converter);
 
 /// Declare or find the mlir::func::FuncOp named \p name. If the
 /// mlir::func::FuncOp does not exist yet, declare it with the signature
 /// translated from the ProcedureDesignator argument.
 /// Due to Fortran implicit function typing rules, the returned FuncOp is not
 /// guaranteed to have the signature from ProcedureDesignator if the FuncOp was
 /// already declared.
 mlir::func::FuncOp

flang/include/flang/Lower/ConvertExpr.h

 /// described the variable storage. Otherwise, the created fir::BoxValue
 /// describes a temporary storage containing \p expr evaluation, and clean-up
 /// for the temporary is added to the provided StatementContext \p stmtCtx.
 fir::ExtendedValue createBoxValue(mlir::Location loc,
                                   AbstractConverter &converter,
                                   const SomeExpr &expr, SymMap &symMap,
                                   StatementContext &stmtCtx);
 
+fir::ProcBoxValue createProcBoxValue(mlir::Location loc,
+                                     AbstractConverter &converter,
+                                     const SomeExpr &expr, SymMap &symMap);
+
 /// Lower an array assignment expression.
 ///
 /// 1. Evaluate the lhs to determine the rank and how to form the ArrayLoad
 /// (e.g., if there is a slicing op).
 /// 2. Scan the rhs, creating the ArrayLoads and evaluate the scalar subparts to
 /// be added to the map.
 /// 3. Create the loop nest and evaluate the elemental expression, threading the
 /// results.

flang/lib/Lower/Bridge.cpp

std::visit(
               Fortran::lower::createSubroutineCall(
                   *this, procRef, explicitIterSpace, implicitIterSpace,
                   localSymbols, ctx, /*isUserDefAssignment=*/true);
             },
 
             // [3] Pointer assignment with possibly empty bounds-spec. R1035: a
             // bounds-spec is a lower bound value.
             [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
-              if (Fortran::evaluate::IsProcedure(assign.rhs))
-                TODO(loc, "procedure pointer assignment");
               std::optional<Fortran::evaluate::DynamicType> lhsType =
                   assign.lhs.GetType();
               std::optional<Fortran::evaluate::DynamicType> rhsType =
                   assign.rhs.GetType();
               // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
               if ((lhsType && lhsType->IsPolymorphic()) ||
                   (rhsType && rhsType->IsPolymorphic()))
                 TODO(loc, "pointer assignment involving polymorphic entity");
 
               llvm::SmallVector<mlir::Value> lbounds;
               for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
                 lbounds.push_back(
                     fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
               if (explicitIterationSpace()) {
                 // Pointer assignment in FORALL context. Copy the rhs box value
                 // into the lhs box variable.
                 genArrayAssignment(assign, stmtCtx, lbounds);
                 return;
               }
+              if (Fortran::evaluate::IsProcedure(assign.rhs)) {
+                fir::ProcBoxValue lhs = Fortran::lower::createProcBoxValue(loc, *this, assign.lhs, localSymbols);
+                auto rhs = Fortran::lower::createProcBoxValue(loc, *this, assign.rhs, localSymbols);
+                auto& builder = getFirOpBuilder();
+
+                builder.create<fir::StoreOp>(loc, getBase(rhs), lhs.getAddr());
+              } else {
                 fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
                 Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs,
                                                     lbounds, stmtCtx);
+              }
             },
 
             // [4] Pointer assignment with bounds-remapping. R1036: a
             // bounds-remapping is a pair, lower bound and upper bound.
             [&](const Fortran::evaluate::Assignment::BoundsRemapping
                     &boundExprs) {
               std::optional<Fortran::evaluate::DynamicType> lhsType =
                   assign.lhs.GetType();

flang/lib/Lower/CallInterface.cpp

public:
   mlir::Type getHostAssociatedTy() const {
     llvm_unreachable("getting host associated type in SignatureBuilder");
   }
 
 private:
   const Fortran::evaluate::characteristics::Procedure &proc;
 };
 
+template <typename T>
+mlir::FunctionType
+translateSignatureImpl(const T &proc,
+                       Fortran::lower::AbstractConverter &converter,
+                       bool forceImplicit = false) {
+  using Fortran::evaluate::characteristics::Procedure;
+  std::optional<Procedure> characteristics =
+      Procedure::Characterize(proc, converter.getFoldingContext());
+  return SignatureBuilder{characteristics.value(), converter, forceImplicit}
+      .getFunctionType();
+}
+
+mlir::FunctionType Fortran::lower::translateSignature(
+    const semantics::Symbol &proc,
+    Fortran::lower::AbstractConverter &converter) {
+  assert(IsProcedure(proc));
+  return translateSignatureImpl(proc, converter);
+}
+
 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();
+  return translateSignatureImpl(proc, converter, forceImplicit);
 }
 
 mlir::func::FuncOp Fortran::lower::getOrDeclareFunction(
     llvm::StringRef name, const Fortran::evaluate::ProcedureDesignator &proc,
     Fortran::lower::AbstractConverter &converter) {
   mlir::ModuleOp module = converter.getModuleOp();
   mlir::func::FuncOp func = fir::FirOpBuilder::getNamedFunction(module, name);
   if (func)

flang/lib/Lower/ConvertExpr.cpp

 //===-- ConvertExpr.cpp ---------------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/ConvertExpr.h"
 #include "flang/Common/default-kinds.h"
 #include "flang/Common/unwrap.h"
+#include "flang/Evaluate/call.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/real.h"
+#include "flang/Evaluate/tools.h"
 #include "flang/Evaluate/traverse.h"
 #include "flang/Lower/Allocatable.h"
 #include "flang/Lower/Bridge.h"
 #include "flang/Lower/BuiltinModules.h"
 #include "flang/Lower/CallInterface.h"
 #include "flang/Lower/Coarray.h"
 #include "flang/Lower/ComponentPath.h"
 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/CustomIntrinsicCall.h"
 #include "flang/Lower/DumpEvaluateExpr.h"
 #include "flang/Lower/IntrinsicCall.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/Runtime.h"
 #include "flang/Lower/Support/Utils.h"
 #include "flang/Lower/Todo.h"
+#include "flang/Optimizer/Builder/BoxValue.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/Factory.h"
 #include "flang/Optimizer/Builder/Runtime/Character.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/Ragged.h"
 #include "flang/Optimizer/Dialect/FIRAttr.h"
 #include "flang/Optimizer/Dialect/FIRDialect.h"
+#include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Optimizer/Support/FatalError.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "flang/Semantics/type.h"
 #include "mlir/Dialect/Func/IR/FuncOps.h"
 #include "llvm/ADT/TypeSwitch.h"
ExtValue genBoxArg(const Fortran::lower::SomeExpr &expr) {
     useBoxArg = saveUseBoxArg;
     return result;
   }
 
   ExtValue genExtValue(const Fortran::lower::SomeExpr &expr) {
     return genval(expr);
   }
 
+  fir::ProcBoxValue genProcBoxValue(const Fortran::lower::SomeExpr &expr) {
+    const auto &proc = DEREF(
+        Fortran::evaluate::UnwrapExpr<Fortran::evaluate::ProcedureDesignator>(
+            expr));
+    if (const auto *component = proc.GetComponent()) {
+      return DEREF(genComponent(*component).getBoxOf<fir::ProcBoxValue>());
+    }
+    const auto symbol = symMap.lookupSymbol(proc.GetSymbol());
+    std::string name = converter.mangleName(*proc.GetSymbol());
+    mlir::func::FuncOp func =
+        Fortran::lower::getOrDeclareFunction(name, proc, converter);
+    const auto funcTy = func.getFunctionType();
+    const mlir::Value address = builder.create<fir::AddrOfOp>(
+        getLoc(), funcTy, builder.getSymbolRefAttr(name));
+    const auto emboxed = builder.create<fir::EmboxProcOp>(
+        getLoc(), builder.getBoxProcType(funcTy), address);
+    return fir::ProcBoxValue{emboxed->getResult(0), emboxed->getResult(1)};
+  }
+
   /// Lower an expression that is a pointer or an allocatable to a
   /// MutableBoxValue.
   fir::MutableBoxValue
   genMutableBoxValue(const Fortran::lower::SomeExpr &expr) {
     // Pointers and allocatables can only be:
     //    - a simple designator "x"
     //    - a component designator "a%b(i,j)%x"
     //    - a function reference "foo()"
Fortran::lower::createSomeArrayBox(Fortran::lower::AbstractConverter &converter,
                                    const Fortran::lower::SomeExpr &expr,
                                    Fortran::lower::SymMap &symMap,
                                    Fortran::lower::StatementContext &stmtCtx) {
   LLVM_DEBUG(expr.AsFortran(llvm::dbgs() << "box designator: ") << '\n');
   return ArrayExprLowering::lowerBoxedArrayExpression(converter, symMap,
                                                       stmtCtx, expr);
 }
 
+fir::ProcBoxValue Fortran::lower::createProcBoxValue(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) {
+  Fortran::lower::StatementContext dummyStmtCtx;
+  return ScalarExprLowering{loc, converter, symMap, dummyStmtCtx}
+      .genProcBoxValue(expr);
+}
+
 fir::MutableBoxValue Fortran::lower::createMutableBox(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap) {
   // MutableBox lowering StatementContext does not need to be propagated
   // to the caller because the result value is a variable, not a temporary
   // expression. The StatementContext clean-up can occur before using the
   // resulting MutableBoxValue. Variables of all other types are handled in the
   // bridge.

flang/lib/Lower/ConvertType.cpp

mlir::Type genDerivedType(const Fortran::semantics::DerivedTypeSpec &tySpec) {
     // (1) The data components.
     for (const auto &field :
          Fortran::semantics::OrderedComponentIterator(tySpec)) {
       // Lowering is assuming non deferred component lower bounds are always 1.
       // Catch any situations where this is not true for now.
       if (componentHasNonDefaultLowerBounds(field))
         TODO(converter.genLocation(field.name()),
              "lowering derived type components with non default lower bounds");
-      if (IsProcedure(field))
-        TODO(converter.genLocation(field.name()), "procedure components");
-      mlir::Type ty = genSymbolType(field);
+      mlir::Type ty;
+      if (IsProcedure(field)) {
+        ty = translateSignature(field, converter);
+        ty = fir::BoxProcType::get(context, ty);
+      } else {
+        ty = genSymbolType(field);
+      }
       // Do not add the parent component (component of the parents are
       // added and should be sufficient, the parent component would
       // duplicate the fields).
       if (field.test(Fortran::semantics::Symbol::Flag::ParentComp))
         continue;
       cs.emplace_back(field.name().ToString(), ty);
     }
 

flang/lib/Optimizer/Builder/FIRBuilder.cpp

if (fieldTy.isa<fir::BoxType>()) {
     if (auto recTy = eleTy.dyn_cast<fir::RecordType>())
       if (recTy.getNumLenParams() > 0)
         TODO(loc, "allocatable and pointer components non deferred length "
                   "parameters");
 
     return fir::MutableBoxValue(component, nonDeferredTypeParams,
                                 /*mutableProperties=*/{});
   }
+  if (auto funTy = fieldTy.dyn_cast<BoxProcType>()) {
+    // TODO: host-assoc pointer
+    return fir::ProcBoxValue{component, {}};
+  }
   llvm::SmallVector<mlir::Value> extents;
   if (auto seqTy = fieldTy.dyn_cast<fir::SequenceType>()) {
     fieldTy = seqTy.getEleTy();
     auto idxTy = builder.getIndexType();
     for (auto extent : seqTy.getShape()) {
       if (extent == fir::SequenceType::getUnknownExtent())
         TODO(loc, "array component shape depending on length parameters");
       extents.emplace_back(builder.createIntegerConstant(loc, idxTy, extent));