[flang] move ASSOCIATED intrinsic optional TARGET handling

[jeanPerier]

Summary

ASSOCIATED intrinsic TARGET handling is weird for OPTIONAL, because as
opposed to other intrinsic arguments, OPTIONAL allocatable and pointers
may be absent when passed to it, and a diassociated pointer TARGET is not
the same as when TARGET is not provided. Hence, it needs custom
handling in lowering.

The handling was done late (in genIntrinsicCall, without the semantic
context), and assumed it would be possible to retrieve the optionality
aspects, but this is brittle, and hard to share with HLFIR.
Move it in CustomIntrinsicCall that is intended to deal with these
corner case.

Also avoid using fir.box<None> as the related fir.if result, and used
the correct fir.box/fir.class type for the target: using a fir.box<None>
here is risky since fir.box<None> are now meant for scalar TYPE(*), and
the TARGET may be ranked.

Move the introduction of the fir.box<None> around the runtime (when
assumed rank are supported, these will become !fir.box<!fir.array<..xNone>>).

[vzakhari]

LGTM

flang/lib/Lower/CustomIntrinsicCall.cpp

281

nit: usually, it would look like /*loadOperand=*/false (with = and without a space before false).

flang/include/flang/Lower/CustomIntrinsicCall.h

 /// dynamically optional arguments (pointers, allocatables, OPTIONAL dummies) in
 /// a safe way.
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_LOWER_CUSTOMINTRINSICCALL_H
 #define FORTRAN_LOWER_CUSTOMINTRINSICCALL_H
 
 #include "flang/Lower/AbstractConverter.h"
+#include "flang/Optimizer/Builder/IntrinsicCall.h"
 #include <functional>
 #include <optional>
 
 namespace Fortran {
 
 namespace evaluate {
 class ProcedureRef;
 struct SpecificIntrinsic;
 } // namespace evaluate
 
 namespace lower {
 
 /// Does the call \p procRef to \p intrinsic need to be handle via this custom
 /// framework due to optional arguments. Otherwise, the tools from
 /// IntrinsicCall.cpp should be used directly.
 bool intrinsicRequiresCustomOptionalHandling(
     const Fortran::evaluate::ProcedureRef &procRef,
     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
     AbstractConverter &converter);
 
 /// Type of callback to be provided to prepare the arguments fetching from an
 /// actual argument expression.
 using OperandPrepare = std::function<void(const Fortran::lower::SomeExpr &)>;
+using OperandPrepareAs = std::function<void(const Fortran::lower::SomeExpr &,
+                                            fir::LowerIntrinsicArgAs)>;
 
 /// Type of the callback to inquire about an argument presence, once the call
 /// preparation was done. An absent optional means the argument is statically
 /// present. An mlir::Value means the presence must be checked at runtime, and
 /// that the value contains the "is present" boolean value.
 using OperandPresent = std::function<std::optional<mlir::Value>(std::size_t)>;
 
 /// Type of the callback to generate an argument reference after the call
 /// preparation was done. For optional arguments, the utility guarantees
 /// these callbacks will only be called in regions where the presence was
 /// verified. This means the getter callback can dereference the argument
 /// without any special care.
 /// For elemental intrinsics, the getter must provide the current iteration
-/// element value.
-using OperandGetter = std::function<fir::ExtendedValue(std::size_t)>;
+/// element value. If the boolean argument is true, the callback must load the
+/// argument before returning it.
+using OperandGetter = std::function<fir::ExtendedValue(std::size_t, bool)>;
 
 /// Given a callback \p prepareOptionalArgument to prepare optional
 /// arguments and a callback \p prepareOtherArgument to prepare non-optional
 /// arguments prepare the intrinsic arguments calls.
 /// It is up to the caller to decide what argument preparation means,
 /// the only contract is that it should later allow the caller to provide
 /// callbacks to generate argument reference given an argument index without
 /// any further knowledge of the argument. The function simply visits
 /// the actual arguments, deciding which ones are dynamically optional,
 /// and calling the callbacks accordingly in argument order.
 void prepareCustomIntrinsicArgument(
     const Fortran::evaluate::ProcedureRef &procRef,
     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
     std::optional<mlir::Type> retTy,
     const OperandPrepare &prepareOptionalArgument,
-    const OperandPrepare &prepareOtherArgument, AbstractConverter &converter);
+    const OperandPrepareAs &prepareOtherArgument, AbstractConverter &converter);
 
 /// Given a callback \p getOperand to generate a reference to the i-th argument,
 /// and a callback \p isPresentCheck to test if an argument is present, this
 /// function lowers the intrinsic calls to \p name whose argument were
 /// previously prepared with prepareCustomIntrinsicArgument. The elemental
 /// aspects must be taken into account by the caller (i.e, the function should
 /// be called during the loop nest generation for elemental intrinsics. It will
 /// not generate any implicit loop nest on its own).

flang/lib/Lower/ConvertExpr.cpp

if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
       using ExvAndPresence = std::pair<ExtValue, std::optional<mlir::Value>>;
       llvm::SmallVector<ExvAndPresence, 4> operands;
       auto prepareOptionalArg = [&](const Fortran::lower::SomeExpr &expr) {
         ExtValue optionalArg = lowerIntrinsicArgumentAsInquired(expr);
         mlir::Value isPresent =
             genActualIsPresentTest(builder, loc, optionalArg);
         operands.emplace_back(optionalArg, isPresent);
       };
-      auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) {
+      auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
+                                 fir::LowerIntrinsicArgAs lowerAs) {
+        switch (lowerAs) {
+        case fir::LowerIntrinsicArgAs::Value:
           operands.emplace_back(genval(expr), std::nullopt);
+          return;
+        case fir::LowerIntrinsicArgAs::Addr:
+          operands.emplace_back(gen(expr), std::nullopt);
+          return;
+        case fir::LowerIntrinsicArgAs::Box:
+          operands.emplace_back(lowerIntrinsicArgumentAsBox(expr),
+                                std::nullopt);
+          return;
+        case fir::LowerIntrinsicArgAs::Inquired:
+          operands.emplace_back(lowerIntrinsicArgumentAsInquired(expr),
+                                std::nullopt);
+          return;
+        }
       };
       Fortran::lower::prepareCustomIntrinsicArgument(
           procRef, *intrinsic, resultType, prepareOptionalArg, prepareOtherArg,
           converter);
 
-      auto getArgument = [&](std::size_t i) -> ExtValue {
-        if (fir::conformsWithPassByRef(
+      auto getArgument = [&](std::size_t i, bool loadArg) -> ExtValue {
+        if (loadArg && fir::conformsWithPassByRef(
                            fir::getBase(operands[i].first).getType()))
           return genLoad(operands[i].first);
         return operands[i].first;
       };
       auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {
         return operands[i].second;
       };
       return Fortran::lower::lowerCustomIntrinsic(
           builder, loc, name, resultType, isPresent, getArgument,
if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
                 return genLoad(builder, loc, optionalArg);
               },
               isPresent);
         } else {
           auto [cc, isPresent, _] = this->genOptionalArrayFetch(expr);
           operands.emplace_back(cc, isPresent);
         }
       };
-      auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr) {
+      auto prepareOtherArg = [&](const Fortran::lower::SomeExpr &expr,
+                                 fir::LowerIntrinsicArgAs lowerAs) {
+        assert(lowerAs == fir::LowerIntrinsicArgAs::Value &&
+               "expect value arguments for elemental intrinsic");
         PushSemantics(ConstituentSemantics::RefTransparent);
         operands.emplace_back(genElementalArgument(expr), std::nullopt);
       };
       Fortran::lower::prepareCustomIntrinsicArgument(
           procRef, *intrinsic, retTy, prepareOptionalArg, prepareOtherArg,
           converter);
 
       fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
       return [=](IterSpace iters) -> ExtValue {
-        auto getArgument = [&](std::size_t i) -> ExtValue {
+        auto getArgument = [&](std::size_t i, bool) -> ExtValue {
           return operands[i].first(iters);
         };
         auto isPresent = [&](std::size_t i) -> std::optional<mlir::Value> {
           return operands[i].second;
         };
         return Fortran::lower::lowerCustomIntrinsic(
             *bldr, loc, name, retTy, isPresent, getArgument, operands.size(),
             getElementCtx());

flang/lib/Lower/CustomIntrinsicCall.cpp

 
 #include "flang/Lower/CustomIntrinsicCall.h"
 #include "flang/Evaluate/expression.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/tools.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Optimizer/Builder/IntrinsicCall.h"
 #include "flang/Optimizer/Builder/Todo.h"
+#include "flang/Semantics/tools.h"
 #include <optional>
 
 /// Is this a call to MIN or MAX intrinsic with arguments that may be absent at
 /// runtime? This is a special case because MIN and MAX can have any number of
 /// arguments.
 static bool isMinOrMaxWithDynamicallyOptionalArg(
     llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
     Fortran::evaluate::FoldingContext &foldingContext) {
static bool isIshftcWithDynamicallyOptionalArg(
   if (name != "ishftc" || procRef.arguments().size() < 3)
     return false;
   auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
       procRef.arguments()[2]);
   return expr &&
          Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, foldingContext);
 }
 
+/// Is this a call to ASSOCIATED where the TARGET is an OPTIONAL (but not a
+/// deallocated allocatable or disassociated pointer)?
+/// Subtle: contrary to other intrinsic optional arguments, disassociated
+/// POINTER and unallocated ALLOCATABLE actual argument are not considered
+/// absent here. This is because ASSOCIATED has special requirements for TARGET
+/// actual arguments that are POINTERs. There is no precise requirements for
+/// ALLOCATABLEs, but all existing Fortran compilers treat them similarly to
+/// POINTERs. That is: unallocated TARGETs cause ASSOCIATED to rerun false.  The
+/// runtime deals with the disassociated/unallocated case. Simply ensures that
+/// TARGET that are OPTIONAL get conditionally emboxed here to convey the
+/// optional aspect to the runtime.
+static bool isAssociatedWithDynamicallyOptionalArg(
+    llvm::StringRef name, const Fortran::evaluate::ProcedureRef &procRef,
+    Fortran::evaluate::FoldingContext &foldingContext) {
+  if (name != "associated" || procRef.arguments().size() < 2)
+    return false;
+  auto *expr = Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(
+      procRef.arguments()[1]);
+  const Fortran::semantics::Symbol *sym{
+      expr ? Fortran::evaluate::UnwrapWholeSymbolOrComponentDataRef(expr)
+           : nullptr};
+  return (sym && Fortran::semantics::IsOptional(*sym));
+}
+
 bool Fortran::lower::intrinsicRequiresCustomOptionalHandling(
     const Fortran::evaluate::ProcedureRef &procRef,
     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
     AbstractConverter &converter) {
   llvm::StringRef name = intrinsic.name;
   Fortran::evaluate::FoldingContext &fldCtx = converter.getFoldingContext();
   return isMinOrMaxWithDynamicallyOptionalArg(name, procRef, fldCtx) ||
-         isIshftcWithDynamicallyOptionalArg(name, procRef, fldCtx);
+         isIshftcWithDynamicallyOptionalArg(name, procRef, fldCtx) ||
+         isAssociatedWithDynamicallyOptionalArg(name, procRef, fldCtx);
 }
 
 /// Generate the FIR+MLIR operations for the generic intrinsic \p name
 /// with arguments \p args and the expected result type \p resultType.
 /// Returned fir::ExtendedValue is the returned Fortran intrinsic value.
 fir::ExtendedValue
 Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
                                  llvm::StringRef name,
Fortran::lower::genIntrinsicCall(fir::FirOpBuilder &builder, mlir::Location loc,
   return result;
 }
 
 static void prepareMinOrMaxArguments(
     const Fortran::evaluate::ProcedureRef &procRef,
     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
     std::optional<mlir::Type> retTy,
     const Fortran::lower::OperandPrepare &prepareOptionalArgument,
-    const Fortran::lower::OperandPrepare &prepareOtherArgument,
+    const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
     Fortran::lower::AbstractConverter &converter) {
   assert(retTy && "MIN and MAX must have a return type");
   mlir::Type resultType = *retTy;
   mlir::Location loc = converter.getCurrentLocation();
   if (fir::isa_char(resultType))
     TODO(loc, "CHARACTER MIN and MAX with dynamically optional arguments");
   for (auto arg : llvm::enumerate(procRef.arguments())) {
     const auto *expr =
         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
     if (!expr)
       continue;
     if (arg.index() <= 1 || !Fortran::evaluate::MayBePassedAsAbsentOptional(
                                 *expr, converter.getFoldingContext())) {
       // Non optional arguments.
-      prepareOtherArgument(*expr);
+      prepareOtherArgument(*expr, fir::LowerIntrinsicArgAs::Value);
     } else {
       // Dynamically optional arguments.
       // Subtle: even for scalar the if-then-else will be generated in the loop
       // nest because the then part will require the current extremum value that
       // may depend on previous array element argument and cannot be outlined.
       prepareOptionalArgument(*expr);
     }
   }
 }
 
 static fir::ExtendedValue
 lowerMinOrMax(fir::FirOpBuilder &builder, mlir::Location loc,
               llvm::StringRef name, std::optional<mlir::Type> retTy,
               const Fortran::lower::OperandPresent &isPresentCheck,
               const Fortran::lower::OperandGetter &getOperand,
               std::size_t numOperands,
               Fortran::lower::StatementContext &stmtCtx) {
   assert(numOperands >= 2 && !isPresentCheck(0) && !isPresentCheck(1) &&
          "min/max must have at least two non-optional args");
   assert(retTy && "MIN and MAX must have a return type");
   mlir::Type resultType = *retTy;
   llvm::SmallVector<fir::ExtendedValue> args;
-  args.push_back(getOperand(0));
-  args.push_back(getOperand(1));
+  const bool loadOperand = true;
+  args.push_back(getOperand(0, loadOperand));
+  args.push_back(getOperand(1, loadOperand));
   mlir::Value extremum = fir::getBase(
       genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx));
 
   for (std::size_t opIndex = 2; opIndex < numOperands; ++opIndex) {
     if (std::optional<mlir::Value> isPresentRuntimeCheck =
             isPresentCheck(opIndex)) {
       // Argument is dynamically optional.
       extremum =
           builder
               .genIfOp(loc, {resultType}, *isPresentRuntimeCheck,
                        /*withElseRegion=*/true)
               .genThen([&]() {
                 llvm::SmallVector<fir::ExtendedValue> args;
                 args.emplace_back(extremum);
-                args.emplace_back(getOperand(opIndex));
+                args.emplace_back(getOperand(opIndex, loadOperand));
                 fir::ExtendedValue newExtremum = genIntrinsicCall(
                     builder, loc, name, resultType, args, stmtCtx);
                 builder.create<fir::ResultOp>(loc, fir::getBase(newExtremum));
               })
               .genElse([&]() { builder.create<fir::ResultOp>(loc, extremum); })
               .getResults()[0];
     } else {
       // Argument is know to be present at compile time.
       llvm::SmallVector<fir::ExtendedValue> args;
       args.emplace_back(extremum);
-      args.emplace_back(getOperand(opIndex));
+      args.emplace_back(getOperand(opIndex, loadOperand));
       extremum = fir::getBase(
           genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx));
     }
   }
   return extremum;
 }
 
 static void prepareIshftcArguments(
     const Fortran::evaluate::ProcedureRef &procRef,
     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
     std::optional<mlir::Type> retTy,
     const Fortran::lower::OperandPrepare &prepareOptionalArgument,
-    const Fortran::lower::OperandPrepare &prepareOtherArgument,
+    const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
     Fortran::lower::AbstractConverter &converter) {
   for (auto arg : llvm::enumerate(procRef.arguments())) {
     const auto *expr =
         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
     assert(expr && "expected all ISHFTC argument to be textually present here");
     if (arg.index() == 2) {
       assert(Fortran::evaluate::MayBePassedAsAbsentOptional(
                  *expr, converter.getFoldingContext()) &&
              "expected ISHFTC SIZE arg to be dynamically optional");
       prepareOptionalArgument(*expr);
     } else {
       // Non optional arguments.
-      prepareOtherArgument(*expr);
+      prepareOtherArgument(*expr, fir::LowerIntrinsicArgAs::Value);
     }
   }
 }
 
 static fir::ExtendedValue
 lowerIshftc(fir::FirOpBuilder &builder, mlir::Location loc,
             llvm::StringRef name, std::optional<mlir::Type> retTy,
             const Fortran::lower::OperandPresent &isPresentCheck,
             const Fortran::lower::OperandGetter &getOperand,
             std::size_t numOperands,
             Fortran::lower::StatementContext &stmtCtx) {
   assert(numOperands == 3 && !isPresentCheck(0) && !isPresentCheck(1) &&
          isPresentCheck(2) &&
          "only ISHFTC SIZE arg is expected to be dynamically optional here");
   assert(retTy && "ISFHTC must have a return type");
   mlir::Type resultType = *retTy;
   llvm::SmallVector<fir::ExtendedValue> args;
-  args.push_back(getOperand(0));
-  args.push_back(getOperand(1));
+  const bool loadOperand = true;
+  args.push_back(getOperand(0, loadOperand));
+  args.push_back(getOperand(1, loadOperand));
   auto iPC = isPresentCheck(2);
   assert(iPC.has_value());
   args.push_back(builder
                      .genIfOp(loc, {resultType}, *iPC,
                               /*withElseRegion=*/true)
                      .genThen([&]() {
-                       fir::ExtendedValue sizeExv = getOperand(2);
+                       fir::ExtendedValue sizeExv = getOperand(2, loadOperand);
                        mlir::Value size = builder.createConvert(
                            loc, resultType, fir::getBase(sizeExv));
                        builder.create<fir::ResultOp>(loc, size);
                      })
                      .genElse([&]() {
                        mlir::Value bitSize = builder.createIntegerConstant(
                            loc, resultType,
                            resultType.cast<mlir::IntegerType>().getWidth());
                        builder.create<fir::ResultOp>(loc, bitSize);
                      })
                      .getResults()[0]);
   return genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx);
 }
 
+static void prepareAssociatedArguments(
+    const Fortran::evaluate::ProcedureRef &procRef,
+    const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+    std::optional<mlir::Type> retTy,
+    const Fortran::lower::OperandPrepare &prepareOptionalArgument,
+    const Fortran::lower::OperandPrepareAs &prepareOtherArgument,
+    Fortran::lower::AbstractConverter &converter) {
+  const auto *pointer = procRef.UnwrapArgExpr(0);
+  const auto *optionalTarget = procRef.UnwrapArgExpr(1);
+  assert(pointer && optionalTarget &&
+         "expected call to associated with a target");
+  prepareOtherArgument(*pointer, fir::LowerIntrinsicArgAs::Inquired);
+  prepareOptionalArgument(*optionalTarget);
+}
+
+static fir::ExtendedValue
+lowerAssociated(fir::FirOpBuilder &builder, mlir::Location loc,
+                llvm::StringRef name, std::optional<mlir::Type> resultType,
+                const Fortran::lower::OperandPresent &isPresentCheck,
+                const Fortran::lower::OperandGetter &getOperand,
+                std::size_t numOperands,
+                Fortran::lower::StatementContext &stmtCtx) {
+  assert(numOperands == 2 && "expect two arguments when TARGET is OPTIONAL");
+  llvm::SmallVector<fir::ExtendedValue> args;
+  args.push_back(getOperand(0, /*loadOperand=*/false));
+  // Ensure a null descriptor is passed to the code lowering Associated if
+  // TARGET is absent.
+  fir::ExtendedValue targetExv = getOperand(1, /*loadOperand=*/false);
+  mlir::Value targetBase = fir::getBase(targetExv);
+  // subtle: isPresentCheck would test for an unallocated/disassociated target,
+  // while the optionality of the target pointer/allocatable is what must be
+  // checked here.
+  mlir::Value isPresent =
+      builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), targetBase);
+  mlir::Type targetType = fir::unwrapRefType(targetBase.getType());
+  mlir::Type targetValueType = fir::unwrapPassByRefType(targetType);
+  mlir::Type boxType = targetType.isa<fir::BaseBoxType>()
+                           ? targetType
+                           : fir::BoxType::get(targetValueType);
+  fir::BoxValue targetBox =
+      builder
+          .genIfOp(loc, {boxType}, isPresent,
+                   /*withElseRegion=*/true)
+          .genThen([&]() {
+            mlir::Value box = builder.createBox(loc, targetExv);
+            mlir::Value cast = builder.createConvert(loc, boxType, box);
+            builder.create<fir::ResultOp>(loc, cast);
+          })
+          .genElse([&]() {
+            mlir::Value absentBox = builder.create<fir::AbsentOp>(loc, boxType);
+            builder.create<fir::ResultOp>(loc, absentBox);
+          })
+          .getResults()[0];
+  args.emplace_back(std::move(targetBox));
+  return genIntrinsicCall(builder, loc, name, resultType, args, stmtCtx);
+}
+
 void Fortran::lower::prepareCustomIntrinsicArgument(
     const Fortran::evaluate::ProcedureRef &procRef,
     const Fortran::evaluate::SpecificIntrinsic &intrinsic,
     std::optional<mlir::Type> retTy,
     const OperandPrepare &prepareOptionalArgument,
-    const OperandPrepare &prepareOtherArgument, AbstractConverter &converter) {
+    const OperandPrepareAs &prepareOtherArgument,
+    AbstractConverter &converter) {
   llvm::StringRef name = intrinsic.name;
   if (name == "min" || name == "max")
     return prepareMinOrMaxArguments(procRef, intrinsic, retTy,
                                     prepareOptionalArgument,
                                     prepareOtherArgument, converter);
+  if (name == "associated")
+    return prepareAssociatedArguments(procRef, intrinsic, retTy,
+                                      prepareOptionalArgument,
+                                      prepareOtherArgument, converter);
   assert(name == "ishftc" && "unexpected custom intrinsic argument call");
   return prepareIshftcArguments(procRef, intrinsic, retTy,
                                 prepareOptionalArgument, prepareOtherArgument,
                                 converter);
 }
 
 fir::ExtendedValue Fortran::lower::lowerCustomIntrinsic(
     fir::FirOpBuilder &builder, mlir::Location loc, llvm::StringRef name,
     std::optional<mlir::Type> retTy, const OperandPresent &isPresentCheck,
     const OperandGetter &getOperand, std::size_t numOperands,
     Fortran::lower::StatementContext &stmtCtx) {
   if (name == "min" || name == "max")
     return lowerMinOrMax(builder, loc, name, retTy, isPresentCheck, getOperand,
                          numOperands, stmtCtx);
+  if (name == "associated")
+    return lowerAssociated(builder, loc, name, retTy, isPresentCheck,
+                           getOperand, numOperands, stmtCtx);
   assert(name == "ishftc" && "unexpected custom intrinsic call");
   return lowerIshftc(builder, loc, name, retTy, isPresentCheck, getOperand,
                      numOperands, stmtCtx);
 }

flang/lib/Optimizer/Builder/IntrinsicCall.cpp

IntrinsicLibrary::genAssociated(mlir::Type resultType,
   auto *pointer =
       args[0].match([&](const fir::MutableBoxValue &x) { return &x; },
                     [&](const auto &) -> const fir::MutableBoxValue * {
                       fir::emitFatalError(loc, "pointer not a MutableBoxValue");
                     });
   const fir::ExtendedValue &target = args[1];
   if (isStaticallyAbsent(target))
     return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, *pointer);
-
-  mlir::Value targetBox;
-  if (fir::valueHasFirAttribute(fir::getBase(target),
-                                fir::getOptionalAttrName())) {
-    // Subtle: contrary to other intrinsic optional arguments, disassociated
-    // POINTER and unallocated ALLOCATABLE actual argument are not considered
-    // absent here. This is because ASSOCIATED has special requirements for
-    // TARGET actual arguments that are POINTERs. There is no precise
-    // requirements for ALLOCATABLEs, but all existing Fortran compilers treat
-    // them similarly to POINTERs. That is: unallocated TARGETs cause ASSOCIATED
-    // to rerun false.  The runtime deals with the disassociated/unallocated
-    // case. Simply ensures that TARGET that are OPTIONAL get conditionally
-    // emboxed here to convey the optional aspect to the runtime.
-    mlir::Type boxType = fir::BoxType::get(builder.getNoneType());
-    auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
-                                                      fir::getBase(target));
-    targetBox = builder
-                    .genIfOp(loc, {boxType}, isPresent,
-                             /*withElseRegion=*/true)
-                    .genThen([&]() {
-                      mlir::Value box = builder.createBox(loc, target);
-                      mlir::Value cast =
-                          builder.createConvert(loc, boxType, box);
-                      builder.create<fir::ResultOp>(loc, cast);
-                    })
-                    .genElse([&]() {
-                      mlir::Value absentBox =
-                          builder.create<fir::AbsentOp>(loc, boxType);
-                      builder.create<fir::ResultOp>(loc, absentBox);
-                    })
-                    .getResults()[0];
-  } else {
-    targetBox = builder.createBox(loc, target);
-  }
+  mlir::Value targetBox = builder.createBox(loc, target);
   mlir::Value pointerBoxRef =
       fir::factory::getMutableIRBox(builder, loc, *pointer);
   auto pointerBox = builder.create<fir::LoadOp>(loc, pointerBoxRef);
   return fir::runtime::genAssociated(builder, loc, pointerBox, targetBox);
 }
 
 // BESSEL_JN
 fir::ExtendedValue

flang/test/Lower/Intrinsics/associated.f90

subroutine associated_test(scalar, array)
   ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"},
   ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<!fir.array<10xf32>> {fir.bindc_name = "optionales_ziel", fir.optional, fir.target}) {
   subroutine test_optional_target_1(p, optionales_ziel)
     real, pointer :: p(:)
     real, optional, target :: optionales_ziel(10)
     print *, associated(p, optionales_ziel)
   ! CHECK:  %[[VAL_2:.*]] = arith.constant 10 : index
   ! CHECK:  %[[VAL_3:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.array<10xf32>>) -> i1
-  ! CHECK:  %[[VAL_4:.*]] = fir.if %[[VAL_3]] -> (!fir.box<none>) {
+  ! CHECK:  %[[VAL_4:.*]] = fir.if %[[VAL_3]] -> (!fir.box<!fir.array<10xf32>>) {
   ! CHECK:    %[[VAL_5:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
   ! CHECK:    %[[VAL_6:.*]] = fir.embox %[[VAL_1]](%[[VAL_5]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
-  ! CHECK:    %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (!fir.box<!fir.array<10xf32>>) -> !fir.box<none>
-  ! CHECK:    fir.result %[[VAL_7]] : !fir.box<none>
+  ! CHECK:    fir.result %[[VAL_6]] : !fir.box<!fir.array<10xf32>>
   ! CHECK:  } else {
-  ! CHECK:    %[[VAL_8:.*]] = fir.absent !fir.box<none>
-  ! CHECK:    fir.result %[[VAL_8]] : !fir.box<none>
+  ! CHECK:    %[[VAL_8:.*]] = fir.absent !fir.box<!fir.array<10xf32>>
+  ! CHECK:    fir.result %[[VAL_8]] : !fir.box<!fir.array<10xf32>>
   ! CHECK:  }
   ! CHECK:  %[[VAL_13:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
   ! CHECK:  %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
-  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_14]], %[[VAL_4]]) {{.*}}: (!fir.box<none>, !fir.box<none>) -> i1
+  ! CHECK:  %[[VAL_15:.*]] = fir.convert %[[VAL_4]] : (!fir.box<!fir.array<10xf32>>) -> !fir.box<none>
+  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_14]], %[[VAL_15]]) {{.*}}: (!fir.box<none>, !fir.box<none>) -> i1
   end subroutine
   
   ! CHECK-LABEL: func @_QPtest_optional_target_2(
   ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"},
   ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.box<!fir.array<?xf32>> {fir.bindc_name = "optionales_ziel", fir.optional, fir.target}) {
   subroutine test_optional_target_2(p, optionales_ziel)
     real, pointer :: p(:)
     real, optional, target :: optionales_ziel(:)
     print *, associated(p, optionales_ziel)
   ! CHECK:  %[[VAL_7:.*]] = fir.is_present %[[VAL_1]] : (!fir.box<!fir.array<?xf32>>) -> i1
-  ! CHECK:  %[[VAL_8:.*]] = fir.if %[[VAL_7]] -> (!fir.box<none>) {
-  ! CHECK:    %[[VAL_9:.*]] = fir.convert %[[VAL_1]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<none>
-  ! CHECK:    fir.result %[[VAL_9]] : !fir.box<none>
+  ! CHECK:  %[[VAL_8:.*]] = fir.if %[[VAL_7]] -> (!fir.box<!fir.array<?xf32>>) {
+  ! CHECK:    fir.result %[[VAL_1]] : !fir.box<!fir.array<?xf32>>
   ! CHECK:  } else {
-  ! CHECK:    %[[VAL_10:.*]] = fir.absent !fir.box<none>
-  ! CHECK:    fir.result %[[VAL_10]] : !fir.box<none>
+  ! CHECK:    %[[VAL_10:.*]] = fir.absent !fir.box<!fir.array<?xf32>>
+  ! CHECK:    fir.result %[[VAL_10]] : !fir.box<!fir.array<?xf32>>
   ! CHECK:  }
   ! CHECK:  %[[VAL_10:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
   ! CHECK:  %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
-  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_11]], %[[VAL_8]]) {{.*}}: (!fir.box<none>, !fir.box<none>) -> i1
+  ! CHECK:  %[[VAL_12:.*]] = fir.convert %[[VAL_8]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<none>
+  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_11]], %[[VAL_12]]) {{.*}}: (!fir.box<none>, !fir.box<none>) -> i1
   end subroutine
   
   ! CHECK-LABEL: func @_QPtest_optional_target_3(
   ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"},
   ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "optionales_ziel", fir.optional}) {
   subroutine test_optional_target_3(p, optionales_ziel)
     real, pointer :: p(:)
     real, optional, pointer :: optionales_ziel(:)
     print *, associated(p, optionales_ziel)
   ! CHECK:  %[[VAL_8:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> i1
-  ! CHECK:  %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.box<none>) {
+  ! CHECK:  %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.box<!fir.ptr<!fir.array<?xf32>>>) {
   ! CHECK:    %[[VAL_10:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
-  ! CHECK:    %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
-  ! CHECK:    fir.result %[[VAL_11]] : !fir.box<none>
+  ! CHECK:    fir.result %[[VAL_10]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
   ! CHECK:  } else {
-  ! CHECK:    %[[VAL_12:.*]] = fir.absent !fir.box<none>
-  ! CHECK:    fir.result %[[VAL_12]] : !fir.box<none>
+  ! CHECK:    %[[VAL_12:.*]] = fir.absent !fir.box<!fir.ptr<!fir.array<?xf32>>>
+  ! CHECK:    fir.result %[[VAL_12]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
   ! CHECK:  }
   ! CHECK:  %[[VAL_11:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
   ! CHECK:  %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
-  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_12]], %[[VAL_9]]) {{.*}}: (!fir.box<none>, !fir.box<none>) -> i1
+  ! CHECK:  %[[VAL_13:.*]] = fir.convert %[[VAL_9]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
+  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_12]], %[[VAL_13]]) {{.*}}: (!fir.box<none>, !fir.box<none>) -> i1
   end subroutine
   
   ! CHECK-LABEL: func @_QPtest_optional_target_4(
   ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"},
   ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>> {fir.bindc_name = "optionales_ziel", fir.optional, fir.target}) {
   subroutine test_optional_target_4(p, optionales_ziel)
     real, pointer :: p(:)
     real, optional, allocatable, target :: optionales_ziel(:)
     print *, associated(p, optionales_ziel)
   ! CHECK:  %[[VAL_8:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> i1
-  ! CHECK:  %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.box<none>) {
+  ! CHECK:  %[[VAL_9:.*]] = fir.if %[[VAL_8]] -> (!fir.box<!fir.heap<!fir.array<?xf32>>>) {
   ! CHECK:    %[[VAL_10:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
-  ! CHECK:    %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (!fir.box<!fir.heap<!fir.array<?xf32>>>) -> !fir.box<none>
-  ! CHECK:    fir.result %[[VAL_11]] : !fir.box<none>
+  ! CHECK:    fir.result %[[VAL_10]] : !fir.box<!fir.heap<!fir.array<?xf32>>>
   ! CHECK:  } else {
-  ! CHECK:    %[[VAL_12:.*]] = fir.absent !fir.box<none>
-  ! CHECK:    fir.result %[[VAL_12]] : !fir.box<none>
+  ! CHECK:    %[[VAL_12:.*]] = fir.absent !fir.box<!fir.heap<!fir.array<?xf32>>>
+  ! CHECK:    fir.result %[[VAL_12]] : !fir.box<!fir.heap<!fir.array<?xf32>>>
   ! CHECK:  }
   ! CHECK:  %[[VAL_11:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
   ! CHECK:  %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
-  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_12]], %[[VAL_9]]) {{.*}}: (!fir.box<none>, !fir.box<none>) -> i1
+  ! CHECK:  %[[VAL_13:.*]] = fir.convert %[[VAL_9]] : (!fir.box<!fir.heap<!fir.array<?xf32>>>) -> !fir.box<none>
+  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_12]], %[[VAL_13]]) {{.*}}: (!fir.box<none>, !fir.box<none>) -> i1
   end subroutine
   
   ! CHECK-LABEL: func @_QPtest_pointer_target(
   ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "p"},
   ! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "pointer_ziel"}) {
   subroutine test_pointer_target(p, pointer_ziel)
     real, pointer :: p(:)
     real, pointer :: pointer_ziel(:)