//===-- 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/Common/Fortran.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/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIRDialect.h"
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
#include "flang/Optimizer/Support/InternalNames.h"
#include "flang/Optimizer/Support/Utils.h"
#include "flang/Semantics/symbol.h"
#include "flang/Semantics/tools.h"
#include <optional>

static mlir::FunctionType
getProcedureType(const Fortran::evaluate::characteristics::Procedure &proc,
                 Fortran::lower::AbstractConverter &converter);

mlir::Type Fortran::lower::getUntypedBoxProcType(mlir::MLIRContext *context) {
  llvm::SmallVector<mlir::Type> resultTys;
  llvm::SmallVector<mlir::Type> inputTys;
  auto untypedFunc = mlir::FunctionType::get(context, inputTys, resultTys);
  return fir::BoxProcType::get(context, untypedFunc);
}

/// Return the type of a dummy procedure given its characteristic (if it has
/// one).
static 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.
  // 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.
  return Fortran::lower::getUntypedBoxProcType(&converter.getMLIRContext());
}

//===----------------------------------------------------------------------===//
// Caller side interface implementation
//===----------------------------------------------------------------------===//

bool Fortran::lower::CallerInterface::hasAlternateReturns() const {
  return procRef.hasAlternateReturns();
}

/// Return the binding label (from BIND(C...)) or the mangled name of the
/// symbol.
static std::string
getProcMangledName(const Fortran::evaluate::ProcedureDesignator &proc,
                   Fortran::lower::AbstractConverter &converter) {
  if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol())
    return converter.mangleName(symbol->GetUltimate());
  assert(proc.GetSpecificIntrinsic() &&
         "expected intrinsic procedure in designator");
  return proc.GetName();
}

std::string Fortran::lower::CallerInterface::getMangledName() const {
  return getProcMangledName(procRef.proc(), converter);
}

const Fortran::semantics::Symbol *
Fortran::lower::CallerInterface::getProcedureSymbol() const {
  return procRef.proc().GetSymbol();
}

bool Fortran::lower::CallerInterface::isIndirectCall() const {
  if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
    return Fortran::semantics::IsPointer(*symbol) ||
           Fortran::semantics::IsDummy(*symbol);
  return false;
}

bool Fortran::lower::CallerInterface::requireDispatchCall() const {
  // Procedure pointer component reference do not require dispatch, but
  // have PASS/NOPASS argument.
  if (const Fortran::semantics::Symbol *sym = procRef.proc().GetSymbol())
    if (Fortran::semantics::IsPointer(*sym))
      return false;
  // calls with NOPASS attribute still have their component so check if it is
  // polymorphic.
  if (const Fortran::evaluate::Component *component =
          procRef.proc().GetComponent()) {
    if (Fortran::semantics::IsPolymorphic(component->base().GetLastSymbol()))
      return true;
  }
  // calls with PASS attribute have the passed-object already set in its
  // arguments. Just check if their is one.
  std::optional<unsigned> passArg = getPassArgIndex();
  if (passArg)
    return true;
  return false;
}

std::optional<unsigned>
Fortran::lower::CallerInterface::getPassArgIndex() const {
  unsigned passArgIdx = 0;
  std::optional<unsigned> passArg;
  for (const auto &arg : getCallDescription().arguments()) {
    if (arg && arg->isPassedObject()) {
      passArg = passArgIdx;
      break;
    }
    ++passArgIdx;
  }
  if (!passArg)
    return passArg;
  // Take into account result inserted as arguments.
  if (std::optional<Fortran::lower::CallInterface<
          Fortran::lower::CallerInterface>::PassedEntity>
          resultArg = getPassedResult()) {
    if (resultArg->passBy == PassEntityBy::AddressAndLength)
      passArg = *passArg + 2;
    else if (resultArg->passBy == PassEntityBy::BaseAddress)
      passArg = *passArg + 1;
  }
  return passArg;
}

mlir::Value Fortran::lower::CallerInterface::getIfPassedArg() const {
  if (std::optional<unsigned> passArg = getPassArgIndex()) {
    assert(actualInputs.size() > *passArg && actualInputs[*passArg] &&
           "passed arg was not set yet");
    return actualInputs[*passArg];
  }
  return {};
}

const Fortran::evaluate::ProcedureDesignator *
Fortran::lower::CallerInterface::getIfIndirectCall() const {
  if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
    if (Fortran::semantics::IsPointer(*symbol) ||
        Fortran::semantics::IsDummy(*symbol))
      return &procRef.proc();
  return nullptr;
}

static mlir::Location
getProcedureDesignatorLoc(const Fortran::evaluate::ProcedureDesignator &proc,
                          Fortran::lower::AbstractConverter &converter) {
  // Note: If the callee is defined in the same file but after the current
  // unit we cannot get its location here and the funcOp is created at the
  // wrong location (i.e, the caller location).
  // To prevent this, it is up to the bridge to first declare all functions
  // defined in the translation unit before lowering any calls or procedure
  // designator references.
  if (const Fortran::semantics::Symbol *symbol = proc.GetSymbol())
    return converter.genLocation(symbol->name());
  // Use current location for intrinsics.
  return converter.getCurrentLocation();
}

mlir::Location Fortran::lower::CallerInterface::getCalleeLocation() const {
  return getProcedureDesignatorLoc(procRef.proc(), converter);
}

// Get dummy argument characteristic for a procedure with implicit interface
// from the actual argument characteristic. The actual argument may not be a F77
// entity. The attribute must be dropped and the shape, if any, must be made
// explicit.
static Fortran::evaluate::characteristics::DummyDataObject
asImplicitArg(Fortran::evaluate::characteristics::DummyDataObject &&dummy) {
  Fortran::evaluate::Shape shape =
      dummy.type.attrs().none() ? dummy.type.shape()
                                : Fortran::evaluate::Shape(dummy.type.Rank());
  return Fortran::evaluate::characteristics::DummyDataObject(
      Fortran::evaluate::characteristics::TypeAndShape(dummy.type.type(),
                                                       std::move(shape)));
}

static Fortran::evaluate::characteristics::DummyArgument
asImplicitArg(Fortran::evaluate::characteristics::DummyArgument &&dummy) {
  return std::visit(
      Fortran::common::visitors{
          [&](Fortran::evaluate::characteristics::DummyDataObject &obj) {
            return Fortran::evaluate::characteristics::DummyArgument(
                std::move(dummy.name), asImplicitArg(std::move(obj)));
          },
          [&](Fortran::evaluate::characteristics::DummyProcedure &proc) {
            return Fortran::evaluate::characteristics::DummyArgument(
                std::move(dummy.name), std::move(proc));
          },
          [](Fortran::evaluate::characteristics::AlternateReturn &x) {
            return Fortran::evaluate::characteristics::DummyArgument(
                std::move(x));
          }},
      dummy.u);
}

static bool isExternalDefinedInSameCompilationUnit(
    const Fortran::evaluate::ProcedureDesignator &proc) {
  if (const auto *symbol{proc.GetSymbol()})
    return symbol->has<Fortran::semantics::SubprogramDetails>() &&
           symbol->owner().IsGlobal();
  return false;
}

Fortran::evaluate::characteristics::Procedure
Fortran::lower::CallerInterface::characterize() const {
  Fortran::evaluate::FoldingContext &foldingContext =
      converter.getFoldingContext();
  std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =
      Fortran::evaluate::characteristics::Procedure::Characterize(
          procRef.proc(), foldingContext);
  assert(characteristic && "Failed to get characteristic from procRef");
  // The characteristic may not contain the argument characteristic if the
  // ProcedureDesignator has no interface, or may mismatch in case of implicit
  // interface.
  if (!characteristic->HasExplicitInterface() ||
      (converter.getLoweringOptions().getLowerToHighLevelFIR() &&
       isExternalDefinedInSameCompilationUnit(procRef.proc()) &&
       characteristic->CanBeCalledViaImplicitInterface())) {
    // In HLFIR lowering, calls to subprogram with implicit interfaces are
    // always prepared according to the actual arguments. This is to support
    // cases where the implicit interfaces are "abused" in old and not so old
    // Fortran code (e.g, passing REAL(8) to CHARACTER(8), passing object
    // pointers to procedure dummies, passing regular procedure dummies to
    // character procedure dummies, omitted arguments....).
    // In all those case, if the subprogram definition is in the same
    // compilation unit, the "characteristic" from Characterize will be the one
    // from the definition, in case of "abuses" (for which semantics raise a
    // warning), lowering will be placed in a difficult position if it is given
    // the dummy characteristic from the definition and an actual that has
    // seemingly nothing to do with it: it would need to battle to anticipate
    // and handle these mismatches (e.g., be able to prepare a fir.boxchar<>
    // from a fir.real<> and so one). This was the approach of the lowering to
    // FIR, and usually lead to compiler bug every time a new "abuse" was met in
    // the wild.
    // Instead, in HLFIR, the dummy characteristic is always computed from the
    // actual for subprogram with implicit interfaces, and in case of call site
    // vs fun.func MLIR function type signature mismatch, a function cast is
    // done before placing the call. This is a hammer that should cover all
    // cases and behave like existing compiler that "do not see" the definition
    // when placing the call.
    characteristic->dummyArguments.clear();
    for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
         procRef.arguments()) {
      // "arg" may be null if this is a call with missing arguments compared
      // to the subprogram definition. Do not compute any characteristic
      // in this case.
      if (arg.has_value()) {
        if (arg.value().isAlternateReturn()) {
          characteristic->dummyArguments.emplace_back(
              Fortran::evaluate::characteristics::AlternateReturn{});
        } else {
          // Argument cannot be optional with implicit interface
          const Fortran::lower::SomeExpr *expr = arg.value().UnwrapExpr();
          assert(expr && "argument in call with implicit interface cannot be "
                         "assumed type");
          std::optional<Fortran::evaluate::characteristics::DummyArgument>
              argCharacteristic =
                  Fortran::evaluate::characteristics::DummyArgument::FromActual(
                      "actual", *expr, foldingContext,
                      /*forImplicitInterface=*/true);
          assert(argCharacteristic &&
                 "failed to characterize argument in implicit call");
          characteristic->dummyArguments.emplace_back(
              asImplicitArg(std::move(*argCharacteristic)));
        }
      }
    }
  }
  return *characteristic;
}

void Fortran::lower::CallerInterface::placeInput(
    const PassedEntity &passedEntity, mlir::Value arg) {
  assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument &&
         passedEntity.firArgument >= 0 &&
         passedEntity.passBy != CallInterface::PassEntityBy::AddressAndLength &&
         "bad arg position");
  actualInputs[passedEntity.firArgument] = arg;
}

void Fortran::lower::CallerInterface::placeAddressAndLengthInput(
    const PassedEntity &passedEntity, mlir::Value addr, mlir::Value len) {
  assert(static_cast<int>(actualInputs.size()) > passedEntity.firArgument &&
         static_cast<int>(actualInputs.size()) > passedEntity.firLength &&
         passedEntity.firArgument >= 0 && passedEntity.firLength >= 0 &&
         passedEntity.passBy == CallInterface::PassEntityBy::AddressAndLength &&
         "bad arg position");
  actualInputs[passedEntity.firArgument] = addr;
  actualInputs[passedEntity.firLength] = len;
}

bool Fortran::lower::CallerInterface::verifyActualInputs() const {
  if (getNumFIRArguments() != actualInputs.size())
    return false;
  for (mlir::Value arg : actualInputs) {
    if (!arg)
      return false;
  }
  return true;
}

mlir::Value
Fortran::lower::CallerInterface::getInput(const PassedEntity &passedEntity) {
  return actualInputs[passedEntity.firArgument];
}

static void walkLengths(
    const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape,
    const Fortran::lower::CallerInterface::ExprVisitor &visitor,
    Fortran::lower::AbstractConverter &converter) {
  Fortran::evaluate::DynamicType dynamicType = typeAndShape.type();
  // Visit 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), /*assumedSize=*/false);
  } else if (dynamicType.category() == Fortran::common::TypeCategory::Derived &&
             !dynamicType.IsUnlimitedPolymorphic()) {
    const Fortran::semantics::DerivedTypeSpec &derivedTypeSpec =
        dynamicType.GetDerivedTypeSpec();
    if (Fortran::semantics::CountLenParameters(derivedTypeSpec) > 0)
      TODO(converter.getCurrentLocation(),
           "function result with derived type length parameters");
  }
}

void Fortran::lower::CallerInterface::walkResultLengths(
    const ExprVisitor &visitor) const {
  assert(characteristic && "characteristic was not computed");
  const Fortran::evaluate::characteristics::FunctionResult &result =
      characteristic->functionResult.value();
  const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
      result.GetTypeAndShape();
  assert(typeAndShape && "no result type");
  return walkLengths(*typeAndShape, visitor, converter);
}

void Fortran::lower::CallerInterface::walkDummyArgumentLengths(
    const PassedEntity &passedEntity, const ExprVisitor &visitor) const {
  if (!passedEntity.characteristics)
    return;
  if (const auto *dummy =
          std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
              &passedEntity.characteristics->u))
    walkLengths(dummy->type, visitor, converter);
}

// Compute extent expr from shapeSpec of an explicit shape.
static Fortran::evaluate::ExtentExpr
getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) {
  if (shapeSpec.ubound().isStar())
    // F'2023 18.5.3 point 5.
    return Fortran::evaluate::ExtentExpr{-1};
  const auto &ubound = shapeSpec.ubound().GetExplicit();
  const auto &lbound = shapeSpec.lbound().GetExplicit();
  assert(lbound && ubound && "shape must be explicit");
  return Fortran::common::Clone(*ubound) - Fortran::common::Clone(*lbound) +
         Fortran::evaluate::ExtentExpr{1};
}

static void
walkExtents(const Fortran::semantics::Symbol &symbol,
            const Fortran::lower::CallerInterface::ExprVisitor &visitor) {
  if (const auto *objectDetails =
          symbol.detailsIf<Fortran::semantics::ObjectEntityDetails>())
    if (objectDetails->shape().IsExplicitShape() ||
        Fortran::semantics::IsAssumedSizeArray(symbol))
      for (const Fortran::semantics::ShapeSpec &shapeSpec :
           objectDetails->shape())
        visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec)),
                /*assumedSize=*/shapeSpec.ubound().isStar());
}

void Fortran::lower::CallerInterface::walkResultExtents(
    const ExprVisitor &visitor) const {
  // Walk directly the result symbol shape (the characteristic shape may contain
  // descriptor inquiries to it that would fail to lower on the caller side).
  const Fortran::semantics::SubprogramDetails *interfaceDetails =
      getInterfaceDetails();
  if (interfaceDetails) {
    walkExtents(interfaceDetails->result(), visitor);
  } else {
    if (procRef.Rank() != 0)
      fir::emitFatalError(
          converter.getCurrentLocation(),
          "only scalar functions may not have an interface symbol");
  }
}

void Fortran::lower::CallerInterface::walkDummyArgumentExtents(
    const PassedEntity &passedEntity, const ExprVisitor &visitor) const {
  const Fortran::semantics::SubprogramDetails *interfaceDetails =
      getInterfaceDetails();
  if (!interfaceDetails)
    return;
  const Fortran::semantics::Symbol *dummy = getDummySymbol(passedEntity);
  assert(dummy && "dummy symbol was not set");
  walkExtents(*dummy, visitor);
}

bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForResult() const {
  assert(characteristic && "characteristic was not computed");
  const std::optional<Fortran::evaluate::characteristics::FunctionResult>
      &result = characteristic->functionResult;
  if (!result || result->CanBeReturnedViaImplicitInterface() ||
      !getInterfaceDetails() || result->IsProcedurePointer())
    return false;
  bool allResultSpecExprConstant = true;
  auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) {
    allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e);
  };
  walkResultLengths(visitor);
  walkResultExtents(visitor);
  return !allResultSpecExprConstant;
}

bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForDummyArgument(
    const PassedEntity &arg) const {
  bool allResultSpecExprConstant = true;
  auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) {
    allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e);
  };
  walkDummyArgumentLengths(arg, visitor);
  walkDummyArgumentExtents(arg, visitor);
  return !allResultSpecExprConstant;
}

mlir::Value Fortran::lower::CallerInterface::getArgumentValue(
    const semantics::Symbol &sym) const {
  mlir::Location loc = converter.getCurrentLocation();
  const Fortran::semantics::SubprogramDetails *ifaceDetails =
      getInterfaceDetails();
  if (!ifaceDetails)
    fir::emitFatalError(
        loc, "mapping actual and dummy arguments requires an interface");
  const std::vector<Fortran::semantics::Symbol *> &dummies =
      ifaceDetails->dummyArgs();
  auto it = std::find(dummies.begin(), dummies.end(), &sym);
  if (it == dummies.end())
    fir::emitFatalError(loc, "symbol is not a dummy in this call");
  FirValue mlirArgIndex = passedArguments[it - dummies.begin()].firArgument;
  return actualInputs[mlirArgIndex];
}

const Fortran::semantics::Symbol *
Fortran::lower::CallerInterface::getDummySymbol(
    const PassedEntity &passedEntity) const {
  const Fortran::semantics::SubprogramDetails *ifaceDetails =
      getInterfaceDetails();
  if (!ifaceDetails)
    return nullptr;
  std::size_t argPosition = 0;
  for (const auto &arg : getPassedArguments()) {
    if (&arg == &passedEntity)
      break;
    ++argPosition;
  }
  if (argPosition >= ifaceDetails->dummyArgs().size())
    return nullptr;
  return ifaceDetails->dummyArgs()[argPosition];
}

mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const {
  if (passedResult)
    return fir::dyn_cast_ptrEleTy(inputs[passedResult->firArgument].type);
  assert(saveResult && !outputs.empty());
  return outputs[0].type;
}

mlir::Type Fortran::lower::CallerInterface::getDummyArgumentType(
    const PassedEntity &passedEntity) const {
  return inputs[passedEntity.firArgument].type;
}

const Fortran::semantics::Symbol &
Fortran::lower::CallerInterface::getResultSymbol() const {
  mlir::Location loc = converter.getCurrentLocation();
  const Fortran::semantics::SubprogramDetails *ifaceDetails =
      getInterfaceDetails();
  if (!ifaceDetails)
    fir::emitFatalError(
        loc, "mapping actual and dummy arguments requires an interface");
  return ifaceDetails->result();
}

const Fortran::semantics::SubprogramDetails *
Fortran::lower::CallerInterface::getInterfaceDetails() const {
  if (const Fortran::semantics::Symbol *iface =
          procRef.proc().GetInterfaceSymbol())
    return iface->GetUltimate()
        .detailsIf<Fortran::semantics::SubprogramDetails>();
  return nullptr;
}

//===----------------------------------------------------------------------===//
// Callee side interface implementation
//===----------------------------------------------------------------------===//

bool Fortran::lower::CalleeInterface::hasAlternateReturns() const {
  return !funit.isMainProgram() &&
         Fortran::semantics::HasAlternateReturns(funit.getSubprogramSymbol());
}

std::string Fortran::lower::CalleeInterface::getMangledName() const {
  if (funit.isMainProgram())
    return fir::NameUniquer::doProgramEntry().str();
  return converter.mangleName(funit.getSubprogramSymbol());
}

const Fortran::semantics::Symbol *
Fortran::lower::CalleeInterface::getProcedureSymbol() const {
  if (funit.isMainProgram())
    return funit.getMainProgramSymbol();
  return &funit.getSubprogramSymbol();
}

mlir::Location Fortran::lower::CalleeInterface::getCalleeLocation() const {
  // FIXME: do NOT use unknown for the anonymous PROGRAM case. We probably
  // should just stash the location in the funit regardless.
  return converter.genLocation(funit.getStartingSourceLoc());
}

Fortran::evaluate::characteristics::Procedure
Fortran::lower::CalleeInterface::characterize() const {
  Fortran::evaluate::FoldingContext &foldingContext =
      converter.getFoldingContext();
  std::optional<Fortran::evaluate::characteristics::Procedure> characteristic =
      Fortran::evaluate::characteristics::Procedure::Characterize(
          funit.getSubprogramSymbol(), foldingContext);
  assert(characteristic && "Fail to get characteristic from symbol");
  return *characteristic;
}

bool Fortran::lower::CalleeInterface::isMainProgram() const {
  return funit.isMainProgram();
}

mlir::func::FuncOp
Fortran::lower::CalleeInterface::addEntryBlockAndMapArguments() {
  // Check for bugs in the front end. The front end must not present multiple
  // definitions of the same procedure.
  if (!func.getBlocks().empty())
    fir::emitFatalError(func.getLoc(),
                        "cannot process subprogram that was already processed");

  // 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.parentHasTupleHostAssoc();
}

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 caller and callee.
//===----------------------------------------------------------------------===//

static void addSymbolAttribute(mlir::func::FuncOp func,
                               const Fortran::semantics::Symbol &sym,
                               mlir::MLIRContext &mlirContext) {
  const Fortran::semantics::Symbol &ultimate = sym.GetUltimate();
  // The link between an internal procedure and its host procedure is lost
  // in FIR if the host is BIND(C) since the internal mangling will not
  // allow retrieving the host bind(C) name, and therefore func.func symbol.
  // Preserve it as an attribute so that this can be later retrieved.
  if (Fortran::semantics::ClassifyProcedure(ultimate) ==
      Fortran::semantics::ProcedureDefinitionClass::Internal) {
    if (ultimate.owner().kind() ==
        Fortran::semantics::Scope::Kind::Subprogram) {
      if (const Fortran::semantics::Symbol *hostProcedure =
              ultimate.owner().symbol()) {
        std::string hostName = Fortran::lower::mangle::mangleName(
            *hostProcedure, /*keepExternalInScope=*/true);
        func->setAttr(
            fir::getHostSymbolAttrName(),
            mlir::SymbolRefAttr::get(
                &mlirContext, mlir::StringAttr::get(&mlirContext, hostName)));
      }
    } else if (ultimate.owner().kind() ==
               Fortran::semantics::Scope::Kind::MainProgram) {
      func->setAttr(fir::getHostSymbolAttrName(),
                    mlir::SymbolRefAttr::get(
                        &mlirContext,
                        mlir::StringAttr::get(
                            &mlirContext, fir::NameUniquer::doProgramEntry())));
    }
  }

  // Only add this on bind(C) functions for which the symbol is not reflected in
  // the current context.
  if (!Fortran::semantics::IsBindCProcedure(sym))
    return;
  std::string name =
      Fortran::lower::mangle::mangleName(sym, /*keepExternalInScope=*/true);
  func->setAttr(fir::getSymbolAttrName(),
                mlir::StringAttr::get(&mlirContext, name));
}

static void
setCUDAAttributes(mlir::func::FuncOp func,
                  const Fortran::semantics::Symbol *sym,
                  std::optional<Fortran::evaluate::characteristics::Procedure>
                      characteristic) {
  if (characteristic && characteristic->cudaSubprogramAttrs) {
    func.getOperation()->setAttr(
        fir::getCUDAAttrName(),
        fir::getCUDAProcAttribute(func.getContext(),
                                  *characteristic->cudaSubprogramAttrs));
  }

  if (sym) {
    if (auto details =
            sym->GetUltimate()
                .detailsIf<Fortran::semantics::SubprogramDetails>()) {
      mlir::Type i64Ty = mlir::IntegerType::get(func.getContext(), 64);
      if (!details->cudaLaunchBounds().empty()) {
        assert(details->cudaLaunchBounds().size() >= 2 &&
               "expect at least 2 values");
        auto maxTPBAttr =
            mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[0]);
        auto minBPMAttr =
            mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[1]);
        mlir::IntegerAttr ubAttr;
        if (details->cudaLaunchBounds().size() > 2)
          ubAttr =
              mlir::IntegerAttr::get(i64Ty, details->cudaLaunchBounds()[2]);
        func.getOperation()->setAttr(
            fir::getCUDALaunchBoundsAttrName(),
            fir::CUDALaunchBoundsAttr::get(func.getContext(), maxTPBAttr,
                                           minBPMAttr, ubAttr));
      }

      if (!details->cudaClusterDims().empty()) {
        assert(details->cudaClusterDims().size() == 3 && "expect 3 values");
        auto xAttr =
            mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[0]);
        auto yAttr =
            mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[1]);
        auto zAttr =
            mlir::IntegerAttr::get(i64Ty, details->cudaClusterDims()[2]);
        func.getOperation()->setAttr(
            fir::getCUDAClusterDimsAttrName(),
            fir::CUDAClusterDimsAttr::get(func.getContext(), xAttr, yAttr,
                                          zAttr));
      }
    }
  }
}

/// Declare drives the different actions to be performed while analyzing the
/// signature and building/finding the mlir::func::FuncOp.
template <typename T>
void Fortran::lower::CallInterface<T>::declare() {
  if (!side().isMainProgram()) {
    characteristic.emplace(side().characterize());
    bool isImplicit = characteristic->CanBeCalledViaImplicitInterface();
    determineInterface(isImplicit, *characteristic);
  }
  // No input/output for main program

  // Create / get funcOp for direct calls. For indirect calls (only meaningful
  // on the caller side), no funcOp has to be created here. The mlir::Value
  // holding the indirection is used when creating the fir::CallOp.
  if (!side().isIndirectCall()) {
    std::string name = side().getMangledName();
    mlir::ModuleOp module = converter.getModuleOp();
    mlir::SymbolTable *symbolTable = converter.getMLIRSymbolTable();
    func = fir::FirOpBuilder::getNamedFunction(module, symbolTable, name);
    if (!func) {
      mlir::Location loc = side().getCalleeLocation();
      mlir::FunctionType ty = genFunctionType();
      func =
          fir::FirOpBuilder::createFunction(loc, module, name, ty, symbolTable);
      if (const Fortran::semantics::Symbol *sym = side().getProcedureSymbol()) {
        if (side().isMainProgram()) {
          func->setAttr(fir::getSymbolAttrName(),
                        mlir::StringAttr::get(&converter.getMLIRContext(),
                                              sym->name().ToString()));
        } else {
          addSymbolAttribute(func, *sym, converter.getMLIRContext());
        }
      }
      for (const auto &placeHolder : llvm::enumerate(inputs))
        if (!placeHolder.value().attributes.empty())
          func.setArgAttrs(placeHolder.index(), placeHolder.value().attributes);

      setCUDAAttributes(func, side().getProcedureSymbol(), characteristic);
    }
  }
}

/// Once the signature has been analyzed and the mlir::func::FuncOp was
/// built/found, map the fir inputs to Fortran entities (the symbols or
/// expressions).
template <typename T>
void Fortran::lower::CallInterface<T>::mapPassedEntities() {
  // map back fir inputs to passed entities
  if constexpr (std::is_same_v<T, Fortran::lower::CalleeInterface>) {
    assert(inputs.size() == func.front().getArguments().size() &&
           "function previously created with different number of arguments");
    for (auto [fst, snd] : llvm::zip(inputs, func.front().getArguments()))
      mapBackInputToPassedEntity(fst, snd);
  } else {
    // On the caller side, map the index of the mlir argument position
    // to Fortran ActualArguments.
    int firPosition = 0;
    for (const FirPlaceHolder &placeHolder : inputs)
      mapBackInputToPassedEntity(placeHolder, firPosition++);
  }
}

template <typename T>
void Fortran::lower::CallInterface<T>::mapBackInputToPassedEntity(
    const FirPlaceHolder &placeHolder, FirValue firValue) {
  PassedEntity &passedEntity =
      placeHolder.passedEntityPosition == FirPlaceHolder::resultEntityPosition
          ? passedResult.value()
          : passedArguments[placeHolder.passedEntityPosition];
  if (placeHolder.property == Property::CharLength)
    passedEntity.firLength = firValue;
  else
    passedEntity.firArgument = firValue;
}

/// Helpers to access ActualArgument/Symbols
static const Fortran::evaluate::ActualArguments &
getEntityContainer(const Fortran::evaluate::ProcedureRef &proc) {
  return proc.arguments();
}

static const std::vector<Fortran::semantics::Symbol *> &
getEntityContainer(Fortran::lower::pft::FunctionLikeUnit &funit) {
  return funit.getSubprogramSymbol()
      .get<Fortran::semantics::SubprogramDetails>()
      .dummyArgs();
}

static const Fortran::evaluate::ActualArgument *getDataObjectEntity(
    const std::optional<Fortran::evaluate::ActualArgument> &arg) {
  if (arg)
    return &*arg;
  return nullptr;
}

static const Fortran::semantics::Symbol &
getDataObjectEntity(const Fortran::semantics::Symbol *arg) {
  assert(arg && "expect symbol for data object entity");
  return *arg;
}

static const Fortran::evaluate::ActualArgument *
getResultEntity(const Fortran::evaluate::ProcedureRef &) {
  return nullptr;
}

static const Fortran::semantics::Symbol &
getResultEntity(Fortran::lower::pft::FunctionLikeUnit &funit) {
  return funit.getSubprogramSymbol()
      .get<Fortran::semantics::SubprogramDetails>()
      .result();
}

/// 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;
  using FirValue = typename CallInterface::FirValue;
  using FortranEntity = typename CallInterface::FortranEntity;
  using FirPlaceHolder = typename CallInterface::FirPlaceHolder;
  using Property = typename CallInterface::Property;
  using TypeAndShape = Fortran::evaluate::characteristics::TypeAndShape;
  using DummyCharacteristics =
      Fortran::evaluate::characteristics::DummyArgument;

public:
  CallInterfaceImpl(CallInterface &i)
      : interface(i), mlirContext{i.converter.getMLIRContext()} {}

  void buildImplicitInterface(
      const Fortran::evaluate::characteristics::Procedure &procedure) {
    // Handle result
    if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
            &result = procedure.functionResult)
      handleImplicitResult(*result, procedure.IsBindC());
    else if (interface.side().hasAlternateReturns())
      addFirResult(mlir::IndexType::get(&mlirContext),
                   FirPlaceHolder::resultEntityPosition, Property::Value);
    // Handle arguments
    const auto &argumentEntities =
        getEntityContainer(interface.side().getCallDescription());
    for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) {
      const Fortran::evaluate::characteristics::DummyArgument
          &argCharacteristics = std::get<0>(pair);
      std::visit(
          Fortran::common::visitors{
              [&](const auto &dummy) {
                const auto &entity = getDataObjectEntity(std::get<1>(pair));
                handleImplicitDummy(&argCharacteristics, dummy, entity);
              },
              [&](const Fortran::evaluate::characteristics::AlternateReturn &) {
                // nothing to do
              },
          },
          argCharacteristics.u);
    }
  }

  void buildExplicitInterface(
      const Fortran::evaluate::characteristics::Procedure &procedure) {
    bool isBindC = procedure.IsBindC();
    // Handle result
    if (const std::optional<Fortran::evaluate::characteristics::FunctionResult>
            &result = procedure.functionResult) {
      if (result->CanBeReturnedViaImplicitInterface())
        handleImplicitResult(*result, isBindC);
      else
        handleExplicitResult(*result);
    } else if (interface.side().hasAlternateReturns()) {
      addFirResult(mlir::IndexType::get(&mlirContext),
                   FirPlaceHolder::resultEntityPosition, Property::Value);
    }
    // Handle arguments
    const auto &argumentEntities =
        getEntityContainer(interface.side().getCallDescription());
    for (auto pair : llvm::zip(procedure.dummyArguments, argumentEntities)) {
      const Fortran::evaluate::characteristics::DummyArgument
          &argCharacteristics = std::get<0>(pair);
      std::visit(
          Fortran::common::visitors{
              [&](const Fortran::evaluate::characteristics::DummyDataObject
                      &dummy) {
                const auto &entity = getDataObjectEntity(std::get<1>(pair));
                if (!isBindC && dummy.CanBePassedViaImplicitInterface())
                  handleImplicitDummy(&argCharacteristics, dummy, entity);
                else
                  handleExplicitDummy(&argCharacteristics, dummy, entity,
                                      isBindC);
              },
              [&](const Fortran::evaluate::characteristics::DummyProcedure
                      &dummy) {
                const auto &entity = getDataObjectEntity(std::get<1>(pair));
                handleImplicitDummy(&argCharacteristics, dummy, entity);
              },
              [&](const Fortran::evaluate::characteristics::AlternateReturn &) {
                // nothing to do
              },
          },
          argCharacteristics.u);
    }
  }

  void appendHostAssocTupleArg(mlir::Type tupTy) {
    mlir::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 std::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 std::nullopt;
  }

  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 (std::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,
      bool isBindC) {
    if (auto proc{result.IsProcedurePointer()}) {
      mlir::Type mlirType = fir::BoxProcType::get(
          &mlirContext, getProcedureType(*proc, interface.converter));
      addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
                   Property::Value);
      return;
    }
    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) {
      if (isBindC) {
        mlir::Type mlirType = translateDynamicType(dynamicType);
        addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
                     Property::Value);
      } else {
        handleImplicitCharacterResult(dynamicType);
      }
    } else if (dynamicType.category() ==
               Fortran::common::TypeCategory::Derived) {
      if (!dynamicType.GetDerivedTypeSpec().IsVectorType()) {
        // 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);
  }

  /// 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 {};
  }

  mlir::Type
  getRefType(Fortran::evaluate::DynamicType dynamicType,
             const Fortran::evaluate::characteristics::DummyDataObject &obj) {
    mlir::Type type = translateDynamicType(dynamicType);
    if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type))
      type = fir::SequenceType::get(*bounds, type);
    return fir::ReferenceType::get(type);
  }

  void handleImplicitDummy(
      const DummyCharacteristics *characteristics,
      const Fortran::evaluate::characteristics::DummyDataObject &obj,
      const FortranEntity &entity) {
    Fortran::evaluate::DynamicType dynamicType = obj.type.type();
    if constexpr (std::is_same_v<FortranEntity,
                                 const Fortran::evaluate::ActualArgument *>) {
      if (entity) {
        if (entity->isPercentVal()) {
          mlir::Type type = translateDynamicType(dynamicType);
          addFirOperand(type, nextPassedArgPosition(), Property::Value,
                        dummyNameAttr(entity));
          addPassedArg(PassEntityBy::Value, entity, characteristics);
          return;
        }
        if (entity->isPercentRef()) {
          mlir::Type refType = getRefType(dynamicType, obj);
          addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
                        dummyNameAttr(entity));
          addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
          return;
        }
      }
    }
    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 refType = getRefType(dynamicType, obj);
      addFirOperand(refType, nextPassedArgPosition(), Property::BaseAddress,
                    dummyNameAttr(entity));
      addPassedArg(PassEntityBy::BaseAddress, entity, characteristics);
    }
  }

  mlir::Type
  translateDynamicType(const Fortran::evaluate::DynamicType &dynamicType) {
    Fortran::common::TypeCategory cat = dynamicType.category();
    // DERIVED
    if (cat == Fortran::common::TypeCategory::Derived) {
      if (dynamicType.IsUnlimitedPolymorphic())
        return mlir::NoneType::get(&mlirContext);
      return getConverter().genType(dynamicType.GetDerivedTypeSpec());
    }
    // 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());
  }

  void handleExplicitDummy(
      const DummyCharacteristics *characteristics,
      const Fortran::evaluate::characteristics::DummyDataObject &obj,
      const FortranEntity &entity, bool isBindC) {
    using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr;

    bool isValueAttr = false;
    [[maybe_unused]] mlir::Location loc =
        interface.converter.getCurrentLocation();
    llvm::SmallVector<mlir::NamedAttribute> attrs = dummyNameAttr(entity);
    auto addMLIRAttr = [&](llvm::StringRef attr) {
      attrs.emplace_back(mlir::StringAttr::get(&mlirContext, attr),
                         mlir::UnitAttr::get(&mlirContext));
    };
    if (obj.attrs.test(Attrs::Optional))
      addMLIRAttr(fir::getOptionalAttrName());
    // Skipping obj.attrs.test(Attrs::Asynchronous), this does not impact the
    // way the argument is passed given flang implement asynch IO synchronously.
    // TODO: it would be safer to treat them as volatile because since Fortran
    // 2018 asynchronous can also be used for C defined asynchronous user
    // processes (see 18.10.4 Asynchronous communication).
    if (obj.attrs.test(Attrs::Contiguous))
      addMLIRAttr(fir::getContiguousAttrName());
    if (obj.attrs.test(Attrs::Value))
      isValueAttr = true; // TODO: do we want an mlir::Attribute as well?
    if (obj.attrs.test(Attrs::Volatile))
      TODO(loc, "VOLATILE in procedure interface");
    if (obj.attrs.test(Attrs::Target))
      addMLIRAttr(fir::getTargetAttrName());
    if (obj.cudaDataAttr)
      attrs.emplace_back(
          mlir::StringAttr::get(&mlirContext, fir::getCUDAAttrName()),
          fir::getCUDADataAttribute(&mlirContext, obj.cudaDataAttr));

    // TODO: intents that require special care (e.g finalization)

    using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
    const Fortran::evaluate::characteristics::TypeAndShape::Attrs &shapeAttrs =
        obj.type.attrs();
    if (shapeAttrs.test(ShapeAttr::Coarray))
      TODO(loc, "coarray: dummy argument coarray in procedure interface");

    // So far assume that if the argument cannot be passed by implicit interface
    // it must be by box. That may no be always true (e.g for simple optionals)

    Fortran::evaluate::DynamicType dynamicType = obj.type.type();
    mlir::Type type = translateDynamicType(dynamicType);
    if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type))
      type = fir::SequenceType::get(*bounds, type);
    if (obj.attrs.test(Attrs::Allocatable))
      type = fir::HeapType::get(type);
    if (obj.attrs.test(Attrs::Pointer))
      type = fir::PointerType::get(type);
    mlir::Type boxType = fir::wrapInClassOrBoxType(
        type, obj.type.type().IsPolymorphic(), obj.type.type().IsAssumedType());

    if (obj.attrs.test(Attrs::Allocatable) || obj.attrs.test(Attrs::Pointer)) {
      // Pass as fir.ref<fir.box> or fir.ref<fir.class>
      mlir::Type boxRefType = fir::ReferenceType::get(boxType);
      addFirOperand(boxRefType, nextPassedArgPosition(), Property::MutableBox,
                    attrs);
      addPassedArg(PassEntityBy::MutableBox, entity, characteristics);
    } else if (obj.IsPassedByDescriptor(isBindC)) {
      // Pass as fir.box or fir.class
      if (isValueAttr &&
          !getConverter().getLoweringOptions().getLowerToHighLevelFIR())
        TODO(loc, "assumed shape dummy argument with VALUE attribute");
      addFirOperand(boxType, nextPassedArgPosition(), Property::Box, attrs);
      addPassedArg(PassEntityBy::Box, entity, characteristics);
    } else if (dynamicType.category() ==
               Fortran::common::TypeCategory::Character) {
      if (isValueAttr && isBindC) {
        // Pass as fir.char<1>
        mlir::Type charTy =
            fir::CharacterType::getSingleton(&mlirContext, dynamicType.kind());
        addFirOperand(charTy, nextPassedArgPosition(), Property::Value, attrs);
        addPassedArg(PassEntityBy::Value, entity, characteristics);
      } else {
        // Pass as fir.box_char
        mlir::Type boxCharTy =
            fir::BoxCharType::get(&mlirContext, dynamicType.kind());
        addFirOperand(boxCharTy, nextPassedArgPosition(), Property::BoxChar,
                      attrs);
        addPassedArg(isValueAttr ? PassEntityBy::CharBoxValueAttribute
                                 : PassEntityBy::BoxChar,
                     entity, characteristics);
      }
    } else {
      // Pass as fir.ref unless it's by VALUE and BIND(C). Also pass-by-value
      // for numerical/logical scalar without OPTIONAL so that the behavior is
      // consistent with gfortran/nvfortran.
      // TODO: pass-by-value for derived type is not supported yet
      mlir::Type passType = fir::ReferenceType::get(type);
      PassEntityBy passBy = PassEntityBy::BaseAddress;
      Property prop = Property::BaseAddress;
      if (isValueAttr) {
        bool isBuiltinCptrType = fir::isa_builtin_cptr_type(type);
        if (isBindC || (!type.isa<fir::SequenceType>() &&
                        !obj.attrs.test(Attrs::Optional) &&
                        (dynamicType.category() !=
                             Fortran::common::TypeCategory::Derived ||
                         isBuiltinCptrType))) {
          passBy = PassEntityBy::Value;
          prop = Property::Value;
          if (isBuiltinCptrType) {
            auto recTy = type.dyn_cast<fir::RecordType>();
            mlir::Type fieldTy = recTy.getTypeList()[0].second;
            passType = fir::ReferenceType::get(fieldTy);
          } else {
            passType = type;
          }
        } else {
          passBy = PassEntityBy::BaseAddressValueAttribute;
        }
      }
      addFirOperand(passType, nextPassedArgPosition(), prop, attrs);
      addPassedArg(passBy, entity, characteristics);
    }
  }

  void handleImplicitDummy(
      const DummyCharacteristics *characteristics,
      const Fortran::evaluate::characteristics::DummyProcedure &proc,
      const FortranEntity &entity) {
    if (!interface.converter.getLoweringOptions().getLowerToHighLevelFIR() &&
        proc.attrs.test(
            Fortran::evaluate::characteristics::DummyProcedure::Attr::Pointer))
      TODO(interface.converter.getCurrentLocation(),
           "procedure pointer arguments");
    const Fortran::evaluate::characteristics::Procedure &procedure =
        proc.procedure.value();
    mlir::Type funcType =
        getProcedureDesignatorType(&procedure, interface.converter);
    if (proc.attrs.test(Fortran::evaluate::characteristics::DummyProcedure::
                            Attr::Pointer)) {
      // Prodecure pointer dummy argument.
      funcType = fir::ReferenceType::get(funcType);
      addFirOperand(funcType, nextPassedArgPosition(), Property::BoxProcRef);
      addPassedArg(PassEntityBy::BoxProcRef, entity, characteristics);
      return;
    }
    // Otherwise, it is a dummy procedure.
    std::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 handleExplicitResult(
      const Fortran::evaluate::characteristics::FunctionResult &result) {
    using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
    mlir::Type mlirType;
    if (auto proc{result.IsProcedurePointer()}) {
      mlirType = fir::BoxProcType::get(
          &mlirContext, getProcedureType(*proc, interface.converter));
      addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
                   Property::Value);
      return;
    }
    const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
        result.GetTypeAndShape();
    assert(typeAndShape && "expect type for non proc pointer result");
    mlirType = translateDynamicType(typeAndShape->type());
    const auto *resTypeAndShape{result.GetTypeAndShape()};
    bool resIsPolymorphic =
        resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
    bool resIsAssumedType =
        resTypeAndShape && resTypeAndShape->type().IsAssumedType();
    if (std::optional<fir::SequenceType::Shape> bounds =
            getBounds(*typeAndShape))
      mlirType = fir::SequenceType::get(*bounds, mlirType);
    if (result.attrs.test(Attr::Allocatable))
      mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType),
                                           resIsPolymorphic, resIsAssumedType);
    if (result.attrs.test(Attr::Pointer))
      mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
                                           resIsPolymorphic, resIsAssumedType);

    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();
  }

  // Return nullopt for scalars, empty vector for assumed rank, and a vector
  // with the shape (may contain unknown extents) for arrays.
  std::optional<fir::SequenceType::Shape> getBounds(
      const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape) {
    using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
    if (typeAndShape.shape().empty() &&
        !typeAndShape.attrs().test(ShapeAttr::AssumedRank))
      return std::nullopt;
    fir::SequenceType::Shape bounds;
    for (const std::optional<Fortran::evaluate::ExtentExpr> &extent :
         typeAndShape.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 = std::nullopt) {
    interface.inputs.emplace_back(
        FirPlaceHolder{type, entityPosition, p, attributes});
  }
  void
  addFirResult(mlir::Type type, int entityPosition, Property p,
               llvm::ArrayRef<mlir::NamedAttribute> attributes = std::nullopt) {
    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, 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(); }

  static FirValue emptyValue() {
    if constexpr (std::is_same_v<Fortran::lower::CalleeInterface, T>) {
      return {};
    } else {
      return -1;
    }
  }

  Fortran::lower::AbstractConverter &getConverter() {
    return interface.converter;
  }
  CallInterface &interface;
  mlir::MLIRContext &mlirContext;
};

template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::isOptional() const {
  if (!characteristics)
    return false;
  return characteristics->IsOptional();
}
template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeModifiedByCall()
    const {
  if (!characteristics)
    return true;
  if (characteristics->GetIntent() == Fortran::common::Intent::In)
    return false;
  return !hasValueAttribute();
}
template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeReadByCall() const {
  if (!characteristics)
    return true;
  return characteristics->GetIntent() != Fortran::common::Intent::Out;
}

template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::testTKR(
    Fortran::common::IgnoreTKR flag) const {
  if (!characteristics)
    return false;
  const auto *dummy =
      std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
          &characteristics->u);
  if (!dummy)
    return false;
  return dummy->ignoreTKR.test(flag);
}

template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::isIntentOut() const {
  if (!characteristics)
    return true;
  return characteristics->GetIntent() == Fortran::common::Intent::Out;
}
template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::mustBeMadeContiguous()
    const {
  if (!characteristics)
    return true;
  const auto *dummy =
      std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
          &characteristics->u);
  if (!dummy)
    return false;
  const auto &shapeAttrs = dummy->type.attrs();
  using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attr;
  if (shapeAttrs.test(ShapeAttrs::AssumedRank) ||
      shapeAttrs.test(ShapeAttrs::AssumedShape))
    return dummy->attrs.test(
        Fortran::evaluate::characteristics::DummyDataObject::Attr::Contiguous);
  if (shapeAttrs.test(ShapeAttrs::DeferredShape))
    return false;
  // Explicit shape arrays are contiguous.
  return dummy->type.Rank() > 0;
}

template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::hasValueAttribute() const {
  if (!characteristics)
    return false;
  const auto *dummy =
      std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
          &characteristics->u);
  return dummy &&
         dummy->attrs.test(
             Fortran::evaluate::characteristics::DummyDataObject::Attr::Value);
}

template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::hasAllocatableAttribute()
    const {
  if (!characteristics)
    return false;
  const auto *dummy =
      std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
          &characteristics->u);
  using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr;
  return dummy && dummy->attrs.test(Attrs::Allocatable);
}

template <typename T>
bool Fortran::lower::CallInterface<
    T>::PassedEntity::mayRequireIntentoutFinalization() const {
  // Conservatively assume that the finalization is needed.
  if (!characteristics)
    return true;

  // No INTENT(OUT) dummy arguments do not require finalization on entry.
  if (!isIntentOut())
    return false;

  const auto *dummy =
      std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
          &characteristics->u);
  if (!dummy)
    return true;

  // POINTER/ALLOCATABLE dummy arguments do not require finalization.
  using Attrs = Fortran::evaluate::characteristics::DummyDataObject::Attr;
  if (dummy->attrs.test(Attrs::Allocatable) ||
      dummy->attrs.test(Attrs::Pointer))
    return false;

  // Polymorphic and unlimited polymorphic INTENT(OUT) dummy arguments
  // may need finalization.
  const Fortran::evaluate::DynamicType &type = dummy->type.type();
  if (type.IsPolymorphic() || type.IsUnlimitedPolymorphic())
    return true;

  // INTENT(OUT) dummy arguments of derived types require finalization,
  // if their type has finalization.
  const Fortran::semantics::DerivedTypeSpec *derived =
      Fortran::evaluate::GetDerivedTypeSpec(type);
  if (!derived)
    return false;

  return Fortran::semantics::IsFinalizable(*derived);
}

template <typename T>
bool Fortran::lower::CallInterface<
    T>::PassedEntity::isSequenceAssociatedDescriptor() const {
  if (!characteristics || passBy != PassEntityBy::Box)
    return false;
  const auto *dummy =
      std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
          &characteristics->u);
  return dummy && dummy->type.CanBeSequenceAssociated();
}

template <typename T>
void Fortran::lower::CallInterface<T>::determineInterface(
    bool isImplicit,
    const Fortran::evaluate::characteristics::Procedure &procedure) {
  CallInterfaceImpl<T> impl(*this);
  if (isImplicit)
    impl.buildImplicitInterface(procedure);
  else
    impl.buildExplicitInterface(procedure);
  // 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);
  }
  SignatureBuilder(const Fortran::evaluate::ProcedureDesignator &procDes,
                   Fortran::lower::AbstractConverter &c)
      : CallInterface{c}, procDesignator{&procDes},
        proc{Fortran::evaluate::characteristics::Procedure::Characterize(
                 procDes, converter.getFoldingContext())
                 .value()} {}
  /// 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 {
    if (procDesignator)
      return getProcMangledName(*procDesignator, converter);
    fir::emitFatalError(
        converter.getCurrentLocation(),
        "should not query name when only building function type");
  }

  /// This is only here to fulfill CRTP dependencies and should not be called.
  mlir::Location getCalleeLocation() const {
    if (procDesignator)
      return getProcedureDesignatorLoc(*procDesignator, converter);
    return converter.getCurrentLocation();
  }

  const Fortran::semantics::Symbol *getProcedureSymbol() const {
    if (procDesignator)
      return procDesignator->GetSymbol();
    return nullptr;
  };

  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() {
    if (interfaceDetermined)
      fir::emitFatalError(converter.getCurrentLocation(),
                          "SignatureBuilder should only be used once");
    // Most unrestricted intrinsic characteristics have the Elemental attribute
    // which triggers CanBeCalledViaImplicitInterface to return false. However,
    // using implicit interface rules is just fine here.
    bool forceImplicit =
        procDesignator && procDesignator->GetSpecificIntrinsic();
    bool isImplicit = forceImplicit || proc.CanBeCalledViaImplicitInterface();
    determineInterface(isImplicit, proc);
    interfaceDetermined = true;
    return genFunctionType();
  }

  mlir::func::FuncOp getOrCreateFuncOp() {
    if (interfaceDetermined)
      fir::emitFatalError(converter.getCurrentLocation(),
                          "SignatureBuilder should only be used once");
    declare();
    interfaceDetermined = true;
    return getFuncOp();
  }

  // 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::ProcedureDesignator *procDesignator = nullptr;
  Fortran::evaluate::characteristics::Procedure proc;
  bool interfaceDetermined = false;
};

mlir::FunctionType Fortran::lower::translateSignature(
    const Fortran::evaluate::ProcedureDesignator &proc,
    Fortran::lower::AbstractConverter &converter) {
  return SignatureBuilder{proc, converter}.getFunctionType();
}

mlir::func::FuncOp Fortran::lower::getOrDeclareFunction(
    const Fortran::evaluate::ProcedureDesignator &proc,
    Fortran::lower::AbstractConverter &converter) {
  mlir::ModuleOp module = converter.getModuleOp();
  std::string name = getProcMangledName(proc, converter);
  mlir::func::FuncOp func = fir::FirOpBuilder::getNamedFunction(
      module, converter.getMLIRSymbolTable(), name);
  if (func)
    return func;

  // 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.
  return SignatureBuilder{proc, converter}.getOrCreateFuncOp();
}

// 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;
}

bool Fortran::lower::isCPtrArgByValueType(mlir::Type ty) {
  return ty.isa<fir::ReferenceType>() &&
         fir::isa_integer(fir::unwrapRefType(ty));
}

// Return the mlir::FunctionType of a procedure
static mlir::FunctionType
getProcedureType(const Fortran::evaluate::characteristics::Procedure &proc,
                 Fortran::lower::AbstractConverter &converter) {
  return SignatureBuilder{proc, converter, false}.genFunctionType();
}