[flang] Lower pointer component in derived type

[clementval]

Summary

This patch lowers pointer component part of derived types to
FIR.

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

Depends on D121383

[clementval]

Rebase

[PeteSteinfeld]

All builds and tests correctly and looks good.

[clementval]

Rebase

flang/include/flang/Lower/Allocatable.h

 class MutableBoxValue;
 } // namespace fir
 
 namespace Fortran::parser {
 struct AllocateStmt;
 struct DeallocateStmt;
 } // namespace Fortran::parser
 
+namespace Fortran::evaluate {
+template <typename T>
+class Expr;
+struct SomeType;
+} // namespace Fortran::evaluate
+
 namespace Fortran::lower {
 class AbstractConverter;
+class StatementContext;
 
 namespace pft {
 struct Variable;
 }
 
 /// Lower an allocate statement to fir.
 void genAllocateStmt(Fortran::lower::AbstractConverter &,
                      const Fortran::parser::AllocateStmt &, mlir::Location);
 
 /// Lower a deallocate statement to fir.
 void genDeallocateStmt(Fortran::lower::AbstractConverter &,
                        const Fortran::parser::DeallocateStmt &, mlir::Location);
 
 /// Create a MutableBoxValue for an allocatable or pointer entity.
 /// If the variables is a local variable that is not a dummy, it will be
 /// initialized to unallocated/disassociated status.
 fir::MutableBoxValue createMutableBox(Fortran::lower::AbstractConverter &,
                                       mlir::Location,
                                       const Fortran::lower::pft::Variable &var,
                                       mlir::Value boxAddr,
                                       mlir::ValueRange nonDeferredParams);
 
+/// Update a MutableBoxValue to describe the entity designated by the expression
+/// \p source. This version takes care of \p source lowering.
+/// If \lbounds is not empty, it is used to defined the MutableBoxValue
+/// lower bounds, otherwise, the lower bounds from \p source are used.
+void associateMutableBox(
+    Fortran::lower::AbstractConverter &, mlir::Location,
+    const fir::MutableBoxValue &,
+    const Fortran::evaluate::Expr<Fortran::evaluate::SomeType> &source,
+    mlir::ValueRange lbounds, Fortran::lower::StatementContext &);
+
 } // namespace Fortran::lower
 
 #endif // FORTRAN_LOWER_ALLOCATABLE_H

flang/include/flang/Lower/BuiltinModules.h

+//===-- BuiltinModules.h --------------------------------------*- C++ -*-===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+///
+/// Define information about builtin derived types from flang/module/xxx.f90
+/// files so that these types can be manipulated by lowering.
+///
+//===----------------------------------------------------------------------===//
+
+#ifndef FORTRAN_LOWER_BUILTINMODULES_H
+#define FORTRAN_LOWER_BUILTINMODULES_H
+
+namespace Fortran::lower::builtin {
+/// Address field name of __builtin_c_f_pointer and __builtin_c_ptr types.
+constexpr char cptrFieldName[] = "__address";
+} // namespace Fortran::lower::builtin
+
+#endif // FORTRAN_LOWER_BUILTINMODULES_H

flang/include/flang/Lower/ConvertExpr.h

 /// 3. Create the loop nest and evaluate the elemental expression, threading the
 /// results.
 /// 4. Copy the resulting array back with ArrayMergeStore to the lhs as
 /// determined per step 1.
 void createSomeArrayAssignment(AbstractConverter &converter,
                                const SomeExpr &lhs, const SomeExpr &rhs,
                                SymMap &symMap, StatementContext &stmtCtx);
 
+/// Lower an array assignment expression with a pre-evaluated left hand side.
+///
+/// 1. Scan the rhs, creating the ArrayLoads and evaluate the scalar subparts to
+/// be added to the map.
+/// 2. Create the loop nest and evaluate the elemental expression, threading the
+/// results.
+/// 3. Copy the resulting array back with ArrayMergeStore to the lhs as
+/// determined per step 1.
+void createSomeArrayAssignment(AbstractConverter &converter,
+                               const fir::ExtendedValue &lhs,
+                               const SomeExpr &rhs, SymMap &symMap,
+                               StatementContext &stmtCtx);
+
 /// Lower an array assignment expression with pre-evaluated left and right
 /// hand sides. This implements an array copy taking into account
 /// non-contiguity and potential overlaps.
 void createSomeArrayAssignment(AbstractConverter &converter,
                                const fir::ExtendedValue &lhs,
                                const fir::ExtendedValue &rhs, SymMap &symMap,
                                StatementContext &stmtCtx);
 

flang/include/flang/Lower/ConvertVariable.h

 
 #ifndef FORTRAN_LOWER_CONVERT_VARIABLE_H
 #define FORTRAN_LOWER_CONVERT_VARIABLE_H
 
 #include "flang/Lower/Support/Utils.h"
 #include "mlir/IR/Value.h"
 #include "llvm/ADT/DenseMap.h"
 
+namespace fir {
+class ExtendedValue;
+} // namespace fir
+
 namespace Fortran ::lower {
 class AbstractConverter;
 class CallerInterface;
 class StatementContext;
 class SymMap;
 namespace pft {
 struct Variable;
 }

 
 /// Instantiate the variables that appear in the specification expressions
 /// of the result of a function call. The instantiated variables are added
 /// to \p symMap.
 void mapCallInterfaceSymbols(AbstractConverter &,
                              const Fortran::lower::CallerInterface &caller,
                              SymMap &symMap);
 
+// TODO: consider saving the initial expression symbol dependence analysis in
+// in the PFT variable and dealing with the dependent symbols instantiation in
+// the fir::GlobalOp body at the fir::GlobalOp creation point rather than by
+// having genExtAddrInInitializer and genInitialDataTarget custom entry points
+// here to deal with this while lowering the initial expression value.
+
 /// Create initial-data-target fir.box in a global initializer region.
 /// This handles the local instantiation of the target variable.
 mlir::Value genInitialDataTarget(Fortran::lower::AbstractConverter &,
                                  mlir::Location, mlir::Type boxType,
                                  const SomeExpr &initialTarget);
 
+/// Generate address \p addr inside an initializer.
+fir::ExtendedValue
+genExtAddrInInitializer(Fortran::lower::AbstractConverter &converter,
+                        mlir::Location loc, const SomeExpr &addr);
+
 } // namespace Fortran::lower
 #endif // FORTRAN_LOWER_CONVERT_VARIABLE_H

flang/include/flang/Lower/Runtime.h

 // style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this
 // module.
 //
 //===----------------------------------------------------------------------===//
 
 #ifndef FORTRAN_LOWER_RUNTIME_H
 #define FORTRAN_LOWER_RUNTIME_H
 
+namespace mlir {
+class Location;
+class Value;
+} // namespace mlir
+
+namespace fir {
+class FirOpBuilder;
+} // namespace fir
+
 namespace Fortran {
 
 namespace parser {
 struct EventPostStmt;
 struct EventWaitStmt;
 struct LockStmt;
 struct PauseStmt;
 struct StopStmt;

 void genSyncImagesStatement(AbstractConverter &,
                             const parser::SyncImagesStmt &);
 void genSyncMemoryStatement(AbstractConverter &,
                             const parser::SyncMemoryStmt &);
 void genSyncTeamStatement(AbstractConverter &, const parser::SyncTeamStmt &);
 void genUnlockStatement(AbstractConverter &, const parser::UnlockStmt &);
 void genPauseStatement(AbstractConverter &, const parser::PauseStmt &);
 
+mlir::Value genAssociated(fir::FirOpBuilder &, mlir::Location,
+                          mlir::Value pointer, mlir::Value target);
+
 } // namespace lower
 } // namespace Fortran
 
 #endif // FORTRAN_LOWER_RUNTIME_H

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

 #include "mlir/IR/OperationSupport.h"
 #include "mlir/IR/Value.h"
 #include "llvm/ADT/SmallVector.h"
 #include "llvm/Support/Compiler.h"
 #include "llvm/Support/raw_ostream.h"
 #include <utility>
 
 namespace fir {
-class CharBoxValue;
+class FirOpBuilder;
+
 class ArrayBoxValue;
+class BoxValue;
+class CharBoxValue;
 class CharArrayBoxValue;
-class ProcBoxValue;
 class MutableBoxValue;
-class BoxValue;
+class ProcBoxValue;
 
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharBoxValue &);
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ArrayBoxValue &);
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharArrayBoxValue &);
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ProcBoxValue &);
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const MutableBoxValue &);
 llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &);
 
public:
   }
 
   CharBoxValue clone(mlir::Value newBase) const { return {newBase, len}; }
 
   /// Convenience alias to get the memory reference to the buffer.
   mlir::Value getBuffer() const { return getAddr(); }
 
   mlir::Value getLen() const { return len; }
+
   friend llvm::raw_ostream &operator<<(llvm::raw_ostream &,
                                        const CharBoxValue &);
   LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
 
 protected:
   mlir::Value len;
 };
 
AbstractArrayBox(llvm::ArrayRef<mlir::Value> extents,
                                                          lbounds.end()} {}
 
   // Every array has extents that describe its shape.
   const llvm::SmallVectorImpl<mlir::Value> &getExtents() const {
     return extents;
   }
 
   // An array expression may have user-defined lower bound values.
-  // If this vector is empty, the default in all dimensions is `1`.
+  // If this vector is empty, the default in all dimensions in `1`.
   const llvm::SmallVectorImpl<mlir::Value> &getLBounds() const {
     return lbounds;
   }
 
   bool lboundsAllOne() const { return lbounds.empty(); }
   std::size_t rank() const { return extents.size(); }
 
 protected:
BoxValue(mlir::Value addr, llvm::ArrayRef<mlir::Value> lbounds,
            llvm::ArrayRef<mlir::Value> explicitExtents = {})
       : AbstractIrBox{addr, lbounds, explicitExtents},
         explicitParams{explicitParams.begin(), explicitParams.end()} {
     assert(verify());
   }
   // TODO: check contiguous attribute of addr
   bool isContiguous() const { return false; }
 
+  // Replace the fir.box, keeping any non-deferred parameters.
+  BoxValue clone(mlir::Value newBox) const {
+    return {newBox, lbounds, explicitParams, extents};
+  }
+
   friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &);
   LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; }
 
   llvm::ArrayRef<mlir::Value> getLBounds() const { return lbounds; }
 
   // The extents member is not guaranteed to be field for arrays. It is only
   // guaranteed to be field for explicit shape arrays. In general,
   // explicit-shape will not come as descriptors, so this field will be empty in

 ExtendedValue substBase(const ExtendedValue &exv, mlir::Value base);
 
 /// Is the extended value `exv` an array?
 bool isArray(const ExtendedValue &exv);
 
 /// Get the type parameters for `exv`.
 llvm::SmallVector<mlir::Value> getTypeParams(const ExtendedValue &exv);
 
+// The generalized function to get a vector of extents is
+// fir::factory::getExtents(). See FIRBuilder.h.
+
+/// Get exactly one extent for any array-like extended value, \p exv. If \p exv
+/// is not an array or has rank less then \p dim, the result will be a nullptr.
+mlir::Value getExtentAtDimension(const ExtendedValue &exv,
+                                 FirOpBuilder &builder, mlir::Location loc,
+                                 unsigned dim);
+
 /// An extended value is a box of values pertaining to a discrete entity. It is
 /// used in lowering to track all the runtime values related to an entity. For
 /// example, an entity may have an address in memory that contains its value(s)
 /// as well as various attribute values that describe the shape and starting
 /// indices if it is an array entity.
 class ExtendedValue : public details::matcher<ExtendedValue> {
 public:
   using VT =
       std::variant<UnboxedValue, CharBoxValue, ArrayBoxValue, CharArrayBoxValue,
                    ProcBoxValue, BoxValue, MutableBoxValue>;
 
   ExtendedValue() : box{UnboxedValue{}} {}
   template <typename A, typename = std::enable_if_t<
                             !std::is_same_v<std::decay_t<A>, ExtendedValue>>>
   constexpr ExtendedValue(A &&a) : box{std::forward<A>(a)} {
     if (const auto *b = getUnboxed()) {
       if (*b) {
         auto type = b->getType();
         if (type.template isa<fir::BoxCharType>())
           fir::emitFatalError(b->getLoc(), "BoxChar should be unboxed");
-        if (auto refType = type.template dyn_cast<fir::ReferenceType>())
-          type = refType.getEleTy();
-        if (auto seqType = type.template dyn_cast<fir::SequenceType>())
-          type = seqType.getEleTy();
+        type = fir::unwrapSequenceType(fir::unwrapRefType(type));
         if (fir::isa_char(type))
           fir::emitFatalError(b->getLoc(),
                               "character buffer should be in CharBoxValue");
       }
     }
   }
 
   template <typename A>

flang/lib/Lower/Allocatable.cpp

fir::MutableBoxValue Fortran::lower::createMutableBox(
   fir::MutableProperties mutableProperties =
       createMutableProperties(converter, loc, var, nonDeferredParams);
   fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties);
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol()))
     fir::factory::disassociateMutableBox(builder, loc, box);
   return box;
 }
+
+//===----------------------------------------------------------------------===//
+// MutableBoxValue reading interface implementation
+//===----------------------------------------------------------------------===//
+
+static bool
+isArraySectionWithoutVectorSubscript(const Fortran::lower::SomeExpr &expr) {
+  return expr.Rank() > 0 && Fortran::evaluate::IsVariable(expr) &&
+         !Fortran::evaluate::UnwrapWholeSymbolDataRef(expr) &&
+         !Fortran::evaluate::HasVectorSubscript(expr);
+}
+
+void Fortran::lower::associateMutableBox(
+    Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+    const fir::MutableBoxValue &box, const Fortran::lower::SomeExpr &source,
+    mlir::ValueRange lbounds, Fortran::lower::StatementContext &stmtCtx) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(source)) {
+    fir::factory::disassociateMutableBox(builder, loc, box);
+    return;
+  }
+  // The right hand side must not be evaluated in a temp.
+  // Array sections can be described by fir.box without making a temp.
+  // Otherwise, do not generate a fir.box to avoid having to later use a
+  // fir.rebox to implement the pointer association.
+  fir::ExtendedValue rhs = isArraySectionWithoutVectorSubscript(source)
+                               ? converter.genExprBox(source, stmtCtx, loc)
+                               : converter.genExprAddr(source, stmtCtx);
+  fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds);
+}

flang/lib/Lower/Bridge.cpp

std::visit(
             // expression then call the procedure.
             [&](const Fortran::evaluate::ProcedureRef &procRef) {
               TODO(toLocation(), "User defined assignment");
             },
 
             // [3] Pointer assignment with possibly empty bounds-spec. R1035: a
             // bounds-spec is a lower bound value.
             [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
-              TODO(toLocation(),
-                   "Pointer assignment with possibly empty bounds-spec");
+              if (IsProcedure(assign.rhs))
+                TODO(loc, "procedure pointer assignment");
+              std::optional<Fortran::evaluate::DynamicType> lhsType =
+                  assign.lhs.GetType();
+              std::optional<Fortran::evaluate::DynamicType> rhsType =
+                  assign.rhs.GetType();
+              // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
+              if ((lhsType && lhsType->IsPolymorphic()) ||
+                  (rhsType && rhsType->IsPolymorphic()))
+                TODO(loc, "pointer assignment involving polymorphic entity");
+
+              // FIXME: in the explicit space context, we want to use
+              // ScalarArrayExprLowering here.
+              fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
+              llvm::SmallVector<mlir::Value> lbounds;
+              for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
+                lbounds.push_back(
+                    fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
+              Fortran::lower::associateMutableBox(*this, loc, lhs, assign.rhs,
+                                                  lbounds, stmtCtx);
+              if (explicitIterationSpace()) {
+                mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
+                if (!inners.empty()) {
+                  // TODO: should force a copy-in/copy-out here.
+                  // e.g., obj%ptr(i+1) => obj%ptr(i)
+                  builder->create<fir::ResultOp>(loc, inners);
+                }
+              }
             },
 
             // [4] Pointer assignment with bounds-remapping. R1036: a
             // bounds-remapping is a pair, lower bound and upper bound.
             [&](const Fortran::evaluate::Assignment::BoundsRemapping
                     &boundExprs) {
-              TODO(toLocation(), "Pointer assignment with bounds-remapping");
+              std::optional<Fortran::evaluate::DynamicType> lhsType =
+                  assign.lhs.GetType();
+              std::optional<Fortran::evaluate::DynamicType> rhsType =
+                  assign.rhs.GetType();
+              // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3.
+              if ((lhsType && lhsType->IsPolymorphic()) ||
+                  (rhsType && rhsType->IsPolymorphic()))
+                TODO(loc, "pointer assignment involving polymorphic entity");
+
+              // FIXME: in the explicit space context, we want to use
+              // ScalarArrayExprLowering here.
+              fir::MutableBoxValue lhs = genExprMutableBox(loc, assign.lhs);
+              if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
+                      assign.rhs)) {
+                fir::factory::disassociateMutableBox(*builder, loc, lhs);
+                return;
+              }
+              llvm::SmallVector<mlir::Value> lbounds;
+              llvm::SmallVector<mlir::Value> ubounds;
+              for (const std::pair<Fortran::evaluate::ExtentExpr,
+                                   Fortran::evaluate::ExtentExpr> &pair :
+                   boundExprs) {
+                const Fortran::evaluate::ExtentExpr &lbExpr = pair.first;
+                const Fortran::evaluate::ExtentExpr &ubExpr = pair.second;
+                lbounds.push_back(
+                    fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
+                ubounds.push_back(
+                    fir::getBase(genExprValue(toEvExpr(ubExpr), stmtCtx)));
+              }
+              // Do not generate a temp in case rhs is an array section.
+              fir::ExtendedValue rhs =
+                  isArraySectionWithoutVectorSubscript(assign.rhs)
+                      ? Fortran::lower::createSomeArrayBox(
+                            *this, assign.rhs, localSymbols, stmtCtx)
+                      : genExprAddr(assign.rhs, stmtCtx);
+              fir::factory::associateMutableBoxWithRemap(*builder, loc, lhs,
+                                                         rhs, lbounds, ubounds);
+              if (explicitIterationSpace()) {
+                mlir::ValueRange inners = explicitIterSpace.getInnerArgs();
+                if (!inners.empty()) {
+                  // TODO: should force a copy-in/copy-out here.
+                  // e.g., obj%ptr(i+1) => obj%ptr(i)
+                  builder->create<fir::ResultOp>(loc, inners);
+                }
+              }
             },
         },
         assign.u);
   }
 
   /// Lowering of CALL statement
   void genFIR(const Fortran::parser::CallStmt &stmt) {
     Fortran::lower::StatementContext stmtCtx;
private:
   void genFIR(const Fortran::parser::AllocateStmt &stmt) {
     Fortran::lower::genAllocateStmt(*this, stmt, toLocation());
   }
 
   void genFIR(const Fortran::parser::DeallocateStmt &stmt) {
     Fortran::lower::genDeallocateStmt(*this, stmt, toLocation());
   }
 
+  /// Nullify pointer object list
+  ///
+  /// For each pointer object, reset the pointer to a disassociated status.
+  /// We do this by setting each pointer to null.
   void genFIR(const Fortran::parser::NullifyStmt &stmt) {
-    TODO(toLocation(), "NullifyStmt lowering");
+    mlir::Location loc = toLocation();
+    for (auto &pointerObject : stmt.v) {
+      const Fortran::lower::SomeExpr *expr =
+          Fortran::semantics::GetExpr(pointerObject);
+      assert(expr);
+      fir::MutableBoxValue box = genExprMutableBox(loc, *expr);
+      fir::factory::disassociateMutableBox(*builder, loc, box);
+    }
   }
 
   //===--------------------------------------------------------------------===//
 
   void genFIR(const Fortran::parser::EventPostStmt &stmt) {
     TODO(toLocation(), "EventPostStmt lowering");
   }
 
   void genFIR(const Fortran::parser::EventWaitStmt &stmt) {
     TODO(toLocation(), "EventWaitStmt lowering");
   }
 
   void genFIR(const Fortran::parser::FormTeamStmt &stmt) {
     TODO(toLocation(), "FormTeamStmt lowering");
   }
 
   void genFIR(const Fortran::parser::LockStmt &stmt) {
     TODO(toLocation(), "LockStmt lowering");
   }
 
+  /// Return true if context is currently an explicit iteration space. A scalar
+  /// assignment expression may be contextually within a user-defined iteration
+  /// space, transforming it into an array expression.
+  bool explicitIterationSpace() { return explicitIterSpace.isActive(); }
+
   /// Generate an array assignment.
   /// This is an assignment expression with rank > 0. The assignment may or may
   /// not be in a WHERE and/or FORALL context.
   void genArrayAssignment(const Fortran::evaluate::Assignment &assign,
                           Fortran::lower::StatementContext &stmtCtx) {
     if (isWholeAllocatable(assign.lhs)) {
       // Assignment to allocatables may require the lhs to be
       // deallocated/reallocated. See Fortran 2018 10.2.1.3 p3
void genFIR(const Fortran::parser::EndWhereStmt &) {
     TODO(toLocation(), "EndWhereStmt lowering");
   }
 
   void genFIR(const Fortran::parser::WhereStmt &stmt) {
     TODO(toLocation(), "WhereStmt lowering");
   }
 
   void genFIR(const Fortran::parser::PointerAssignmentStmt &stmt) {
-    TODO(toLocation(), "PointerAssignmentStmt lowering");
+    genAssignment(*stmt.typedAssignment->v);
   }
 
   void genFIR(const Fortran::parser::AssignmentStmt &stmt) {
     genAssignment(*stmt.typedAssignment->v);
   }
 
   void genFIR(const Fortran::parser::SyncAllStmt &stmt) {
     TODO(toLocation(), "SyncAllStmt lowering");

flang/lib/Lower/ConvertExpr.cpp

 //===-- ConvertExpr.cpp ---------------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/ConvertExpr.h"
 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/traverse.h"
 #include "flang/Lower/AbstractConverter.h"
+#include "flang/Lower/Allocatable.h"
+#include "flang/Lower/BuiltinModules.h"
 #include "flang/Lower/CallInterface.h"
 #include "flang/Lower/ComponentPath.h"
 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/CustomIntrinsicCall.h"
 #include "flang/Lower/DumpEvaluateExpr.h"
 #include "flang/Lower/IntrinsicCall.h"
 #include "flang/Lower/Mangler.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/Factory.h"
 #include "flang/Optimizer/Builder/LowLevelIntrinsics.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
+#include "flang/Optimizer/Support/Matcher.h"
 #include "flang/Semantics/expression.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "flang/Semantics/type.h"
 #include "mlir/Dialect/Func/IR/FuncOps.h"
 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/Debug.h"
 
public:
   ExtValue genval(const Fortran::evaluate::ProcedureDesignator &proc) {
     TODO(getLoc(), "genval ProcedureDesignator");
   }
 
   ExtValue genval(const Fortran::evaluate::NullPointer &) {
     TODO(getLoc(), "genval NullPointer");
   }
 
+  static bool
+  isDerivedTypeWithLengthParameters(const Fortran::semantics::Symbol &sym) {
+    if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType())
+      if (const Fortran::semantics::DerivedTypeSpec *derived =
+              declTy->AsDerived())
+        return Fortran::semantics::CountLenParameters(*derived) > 0;
+    return false;
+  }
+
+  static bool isBuiltinCPtr(const Fortran::semantics::Symbol &sym) {
+    if (const Fortran::semantics::DeclTypeSpec *declType = sym.GetType())
+      if (const Fortran::semantics::DerivedTypeSpec *derived =
+              declType->AsDerived())
+        return Fortran::semantics::IsIsoCType(derived);
+    return false;
+  }
+
+  /// Lower structure constructor without a temporary. This can be used in
+  /// fir::GloablOp, and assumes that the structure component is a constant.
+  ExtValue genStructComponentInInitializer(
+      const Fortran::evaluate::StructureConstructor &ctor) {
+    mlir::Location loc = getLoc();
+    mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor));
+    auto recTy = ty.cast<fir::RecordType>();
+    auto fieldTy = fir::FieldType::get(ty.getContext());
+    mlir::Value res = builder.create<fir::UndefOp>(loc, recTy);
+
+    for (const auto &[sym, expr] : ctor.values()) {
+      // Parent components need more work because they do not appear in the
+      // fir.rec type.
+      if (sym->test(Fortran::semantics::Symbol::Flag::ParentComp))
+        TODO(loc, "parent component in structure constructor");
+
+      llvm::StringRef name = toStringRef(sym->name());
+      mlir::Type componentTy = recTy.getType(name);
+      // FIXME: type parameters must come from the derived-type-spec
+      auto field = builder.create<fir::FieldIndexOp>(
+          loc, fieldTy, name, ty,
+          /*typeParams=*/mlir::ValueRange{} /*TODO*/);
+
+      if (Fortran::semantics::IsAllocatable(sym))
+        TODO(loc, "allocatable component in structure constructor");
+
+      if (Fortran::semantics::IsPointer(sym)) {
+        mlir::Value initialTarget = Fortran::lower::genInitialDataTarget(
+            converter, loc, componentTy, expr.value());
+        res = builder.create<fir::InsertValueOp>(
+            loc, recTy, res, initialTarget,
+            builder.getArrayAttr(field.getAttributes()));
+        continue;
+      }
+
+      if (isDerivedTypeWithLengthParameters(sym))
+        TODO(loc, "component with length parameters in structure constructor");
+
+      if (isBuiltinCPtr(sym)) {
+        // Builtin c_ptr and c_funptr have special handling because initial
+        // value are handled for them as an extension.
+        mlir::Value addr = fir::getBase(Fortran::lower::genExtAddrInInitializer(
+            converter, loc, expr.value()));
+        if (addr.getType() == componentTy) {
+          // Do nothing. The Ev::Expr was returned as a value that can be
+          // inserted directly to the component without an intermediary.
+        } else {
+          // The Ev::Expr returned is an initializer that is a pointer (e.g.,
+          // null) that must be inserted into an intermediate cptr record
+          // value's address field, which ought to be an intptr_t on the target.
+          assert((fir::isa_ref_type(addr.getType()) ||
+                  addr.getType().isa<mlir::FunctionType>()) &&
+                 "expect reference type for address field");
+          assert(fir::isa_derived(componentTy) &&
+                 "expect C_PTR, C_FUNPTR to be a record");
+          auto cPtrRecTy = componentTy.cast<fir::RecordType>();
+          llvm::StringRef addrFieldName =
+              Fortran::lower::builtin::cptrFieldName;
+          mlir::Type addrFieldTy = cPtrRecTy.getType(addrFieldName);
+          auto addrField = builder.create<fir::FieldIndexOp>(
+              loc, fieldTy, addrFieldName, componentTy,
+              /*typeParams=*/mlir::ValueRange{});
+          mlir::Value castAddr = builder.createConvert(loc, addrFieldTy, addr);
+          auto undef = builder.create<fir::UndefOp>(loc, componentTy);
+          addr = builder.create<fir::InsertValueOp>(
+              loc, componentTy, undef, castAddr,
+              builder.getArrayAttr(addrField.getAttributes()));
+        }
+        res = builder.create<fir::InsertValueOp>(
+            loc, recTy, res, addr, builder.getArrayAttr(field.getAttributes()));
+        continue;
+      }
+
+      mlir::Value val = fir::getBase(genval(expr.value()));
+      assert(!fir::isa_ref_type(val.getType()) && "expecting a constant value");
+      mlir::Value castVal = builder.createConvert(loc, componentTy, val);
+      res = builder.create<fir::InsertValueOp>(
+          loc, recTy, res, castVal,
+          builder.getArrayAttr(field.getAttributes()));
+    }
+    return res;
+  }
+
+  /// A structure constructor is lowered two ways. In an initializer context,
+  /// the entire structure must be constant, so the aggregate value is
+  /// constructed inline. This allows it to be the body of a GlobalOp.
+  /// Otherwise, the structure constructor is in an expression. In that case, a
+  /// temporary object is constructed in the stack frame of the procedure.
   ExtValue genval(const Fortran::evaluate::StructureConstructor &ctor) {
-    TODO(getLoc(), "genval StructureConstructor");
+    if (inInitializer)
+      return genStructComponentInInitializer(ctor);
+    mlir::Location loc = getLoc();
+    mlir::Type ty = translateSomeExprToFIRType(converter, toEvExpr(ctor));
+    auto recTy = ty.cast<fir::RecordType>();
+    auto fieldTy = fir::FieldType::get(ty.getContext());
+    mlir::Value res = builder.createTemporary(loc, recTy);
+
+    for (const auto &value : ctor.values()) {
+      const Fortran::semantics::Symbol &sym = *value.first;
+      const Fortran::lower::SomeExpr &expr = value.second.value();
+      // Parent components need more work because they do not appear in the
+      // fir.rec type.
+      if (sym.test(Fortran::semantics::Symbol::Flag::ParentComp))
+        TODO(loc, "parent component in structure constructor");
+
+      if (isDerivedTypeWithLengthParameters(sym))
+        TODO(loc, "component with length parameters in structure constructor");
+
+      llvm::StringRef name = toStringRef(sym.name());
+      // FIXME: type parameters must come from the derived-type-spec
+      mlir::Value field = builder.create<fir::FieldIndexOp>(
+          loc, fieldTy, name, ty,
+          /*typeParams=*/mlir::ValueRange{} /*TODO*/);
+      mlir::Type coorTy = builder.getRefType(recTy.getType(name));
+      auto coor = builder.create<fir::CoordinateOp>(loc, coorTy,
+                                                    fir::getBase(res), field);
+      ExtValue to = fir::factory::componentToExtendedValue(builder, loc, coor);
+      to.match(
+          [&](const fir::UnboxedValue &toPtr) {
+            ExtValue value = genval(expr);
+            fir::factory::genScalarAssignment(builder, loc, to, value);
+          },
+          [&](const fir::CharBoxValue &) {
+            ExtValue value = genval(expr);
+            fir::factory::genScalarAssignment(builder, loc, to, value);
+          },
+          [&](const fir::ArrayBoxValue &) {
+            Fortran::lower::createSomeArrayAssignment(converter, to, expr,
+                                                      symMap, stmtCtx);
+          },
+          [&](const fir::CharArrayBoxValue &) {
+            Fortran::lower::createSomeArrayAssignment(converter, to, expr,
+                                                      symMap, stmtCtx);
+          },
+          [&](const fir::BoxValue &toBox) {
+            fir::emitFatalError(loc, "derived type components must not be "
+                                     "represented by fir::BoxValue");
+          },
+          [&](const fir::MutableBoxValue &toBox) {
+            if (toBox.isPointer()) {
+              Fortran::lower::associateMutableBox(
+                  converter, loc, toBox, expr, /*lbounds=*/llvm::None, stmtCtx);
+              return;
+            }
+            // For allocatable components, a deep copy is needed.
+            TODO(loc, "allocatable components in derived type assignment");
+          },
+          [&](const fir::ProcBoxValue &toBox) {
+            TODO(loc, "procedure pointer component in derived type assignment");
+          });
+    }
+    return res;
   }
 
   /// Lowering of an <i>ac-do-variable</i>, which is not a Symbol.
   ExtValue genval(const Fortran::evaluate::ImpliedDoIndex &var) {
     return converter.impliedDoBinding(toStringRef(var.name));
   }
 
   ExtValue genval(const Fortran::evaluate::DescriptorInquiry &desc) {
if constexpr (TC == Fortran::common::TypeCategory::Character) {
               builder.getIndexVectorAttr(rangeBounds));
           rangeSize = 0;
         }
       } while (con.IncrementSubscripts(subscripts));
       return fir::ArrayBoxValue{array, extents, lbounds};
     }
   }
 
+  fir::ExtendedValue genArrayLit(
+      const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) {
+    mlir::Location loc = getLoc();
+    mlir::IndexType idxTy = builder.getIndexType();
+    Fortran::evaluate::ConstantSubscript size =
+        Fortran::evaluate::GetSize(con.shape());
+    fir::SequenceType::Shape shape(con.shape().begin(), con.shape().end());
+    mlir::Type eleTy = converter.genType(con.GetType().GetDerivedTypeSpec());
+    auto arrayTy = fir::SequenceType::get(shape, eleTy);
+    mlir::Value array = builder.create<fir::UndefOp>(loc, arrayTy);
+    llvm::SmallVector<mlir::Value> lbounds;
+    llvm::SmallVector<mlir::Value> extents;
+    for (auto [lb, extent] : llvm::zip(con.lbounds(), con.shape())) {
+      lbounds.push_back(builder.createIntegerConstant(loc, idxTy, lb - 1));
+      extents.push_back(builder.createIntegerConstant(loc, idxTy, extent));
+    }
+    if (size == 0)
+      return fir::ArrayBoxValue{array, extents, lbounds};
+    Fortran::evaluate::ConstantSubscripts subscripts = con.lbounds();
+    do {
+      mlir::Value derivedVal = fir::getBase(genval(con.At(subscripts)));
+      llvm::SmallVector<mlir::Attribute> idx;
+      for (auto [dim, lb] : llvm::zip(subscripts, con.lbounds()))
+        idx.push_back(builder.getIntegerAttr(idxTy, dim - lb));
+      array = builder.create<fir::InsertValueOp>(
+          loc, arrayTy, array, derivedVal, builder.getArrayAttr(idx));
+    } while (con.IncrementSubscripts(subscripts));
+    return fir::ArrayBoxValue{array, extents, lbounds};
+  }
+
   template <Fortran::common::TypeCategory TC, int KIND>
   ExtValue
   genval(const Fortran::evaluate::Constant<Fortran::evaluate::Type<TC, KIND>>
              &con) {
     if (con.Rank() > 0)
       return genArrayLit(con);
     std::optional<Fortran::evaluate::Scalar<Fortran::evaluate::Type<TC, KIND>>>
         opt = con.GetScalarValue();
     assert(opt.has_value() && "constant has no value");
     if constexpr (TC == Fortran::common::TypeCategory::Character) {
       return genScalarLit<KIND>(opt.value(), con.LEN());
     } else {
       return genScalarLit<TC, KIND>(opt.value());
     }
   }
 
   fir::ExtendedValue genval(
       const Fortran::evaluate::Constant<Fortran::evaluate::SomeDerived> &con) {
-    TODO(getLoc(), "genval constant derived");
+    if (con.Rank() > 0)
+      return genArrayLit(con);
+    if (auto ctor = con.GetScalarValue())
+      return genval(ctor.value());
+    fir::emitFatalError(getLoc(),
+                        "constant of derived type has no constructor");
   }
 
   template <typename A>
   ExtValue genval(const Fortran::evaluate::ArrayConstructor<A> &) {
     TODO(getLoc(), "genval ArrayConstructor<A>");
   }
 
   ExtValue gen(const Fortran::evaluate::ComplexPart &x) {
void Fortran::lower::createSomeArrayAssignment(
     Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
   LLVM_DEBUG(lhs.AsFortran(llvm::dbgs() << "onto array: ") << '\n';
              rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
   ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
 }
 
 void Fortran::lower::createSomeArrayAssignment(
     Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
+    const Fortran::lower::SomeExpr &rhs, Fortran::lower::SymMap &symMap,
+    Fortran::lower::StatementContext &stmtCtx) {
+  LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
+             rhs.AsFortran(llvm::dbgs() << "assign expression: ") << '\n';);
+  ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
+}
+
+void Fortran::lower::createSomeArrayAssignment(
+    Fortran::lower::AbstractConverter &converter, const fir::ExtendedValue &lhs,
     const fir::ExtendedValue &rhs, Fortran::lower::SymMap &symMap,
     Fortran::lower::StatementContext &stmtCtx) {
   LLVM_DEBUG(llvm::dbgs() << "onto array: " << lhs << '\n';
              llvm::dbgs() << "assign expression: " << rhs << '\n';);
   ArrayExprLowering::lowerArrayAssignment(converter, symMap, stmtCtx, lhs, rhs);
 }
 
 void Fortran::lower::createAllocatableArrayAssignment(

flang/lib/Lower/ConvertVariable.cpp

 static mlir::Type unwrapElementType(mlir::Type type) {
   if (mlir::Type ty = fir::dyn_cast_ptrOrBoxEleTy(type))
     type = ty;
   if (auto seqType = type.dyn_cast<fir::SequenceType>())
     type = seqType.getEleTy();
   return type;
 }
 
+fir::ExtendedValue Fortran::lower::genExtAddrInInitializer(
+    Fortran::lower::AbstractConverter &converter, mlir::Location loc,
+    const Fortran::lower::SomeExpr &addr) {
+  Fortran::lower::SymMap globalOpSymMap;
+  Fortran::lower::AggregateStoreMap storeMap;
+  Fortran::lower::StatementContext stmtCtx;
+  if (const Fortran::semantics::Symbol *sym =
+          Fortran::evaluate::GetFirstSymbol(addr)) {
+    // Length parameters processing will need care in global initializer
+    // context.
+    if (hasDerivedTypeWithLengthParameters(*sym))
+      TODO(loc, "initial-data-target with derived type length parameters");
+
+    auto var = Fortran::lower::pft::Variable(*sym, /*global=*/true);
+    Fortran::lower::instantiateVariable(converter, var, globalOpSymMap,
+                                        storeMap);
+  }
+  return Fortran::lower::createInitializerAddress(loc, converter, addr,
+                                                  globalOpSymMap, stmtCtx);
+}
+
 /// create initial-data-target fir.box in a global initializer region.
 mlir::Value Fortran::lower::genInitialDataTarget(
     Fortran::lower::AbstractConverter &converter, mlir::Location loc,
     mlir::Type boxType, const Fortran::lower::SomeExpr &initialTarget) {
   Fortran::lower::SymMap globalOpSymMap;
   Fortran::lower::AggregateStoreMap storeMap;
   Fortran::lower::StatementContext stmtCtx;
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();

flang/lib/Lower/IntrinsicCall.cpp

 // style (https://mlir.llvm.org/getting_started/DeveloperGuide/) is used in this
 // module.
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/IntrinsicCall.h"
 #include "flang/Common/static-multimap-view.h"
 #include "flang/Lower/Mangler.h"
+#include "flang/Lower/Runtime.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/Reduction.h"
+#include "flang/Optimizer/Dialect/FIROpsSupport.h"
 #include "flang/Optimizer/Support/FatalError.h"
 #include "mlir/Dialect/LLVMIR/LLVMDialect.h"
 #include "llvm/Support/CommandLine.h"
 
 #define DEBUG_TYPE "flang-lower-intrinsic"
 
 #define PGMATH_DECLARE
 #include "flang/Evaluate/pgmath.h.inc"
struct IntrinsicLibrary {
   getRuntimeCallGenerator(llvm::StringRef name,
                           mlir::FunctionType soughtFuncType);
 
   /// Lowering for the ABS intrinsic. The ABS intrinsic expects one argument in
   /// the llvm::ArrayRef. The ABS intrinsic is lowered into MLIR/FIR operation
   /// if the argument is an integer, into llvm intrinsics if the argument is
   /// real and to the `hypot` math routine if the argument is of complex type.
   mlir::Value genAbs(mlir::Type, llvm::ArrayRef<mlir::Value>);
+  fir::ExtendedValue genAssociated(mlir::Type,
+                                   llvm::ArrayRef<fir::ExtendedValue>);
   template <Extremum, ExtremumBehavior>
   mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>);
   /// Lowering for the IAND intrinsic. The IAND intrinsic expects two arguments
   /// in the llvm::ArrayRef.
   mlir::Value genIand(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genSum(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   /// Define the different FIR generators that can be mapped to intrinsic to
   /// generate the related code. The intrinsic is lowered into an MLIR
struct IntrinsicHandler {
   IntrinsicLibrary::Generator generator;
   // The following may be omitted in the table below.
   Fortran::lower::IntrinsicArgumentLoweringRules argLoweringRules = {};
   bool isElemental = true;
 };
 
 constexpr auto asValue = Fortran::lower::LowerIntrinsicArgAs::Value;
 constexpr auto asBox = Fortran::lower::LowerIntrinsicArgAs::Box;
+constexpr auto asInquired = Fortran::lower::LowerIntrinsicArgAs::Inquired;
 using I = IntrinsicLibrary;
 
 /// Flag to indicate that an intrinsic argument has to be handled as
 /// being dynamically optional (e.g. special handling when actual
 /// argument is an optional variable in the current scope).
 static constexpr bool handleDynamicOptional = true;
 
 /// Table that drives the fir generation depending on the intrinsic.
 /// one to one mapping with Fortran arguments. If no mapping is
 /// defined here for a generic intrinsic, genRuntimeCall will be called
 /// to look for a match in the runtime a emit a call. Note that the argument
 /// lowering rules for an intrinsic need to be provided only if at least one
 /// argument must not be lowered by value. In which case, the lowering rules
 /// should be provided for all the intrinsic arguments for completeness.
 static constexpr IntrinsicHandler handlers[]{
     {"abs", &I::genAbs},
+    {"associated",
+     &I::genAssociated,
+     {{{"pointer", asInquired}, {"target", asInquired}}},
+     /*isElemental=*/false},
     {"iand", &I::genIand},
     {"sum",
      &I::genSum,
      {{{"array", asBox},
        {"dim", asValue},
        {"mask", asBox, handleDynamicOptional}}},
      /*isElemental=*/false},
 };
if (fir::isa_complex(type)) {
     // Use HYPOT to fulfill the no underflow/overflow requirement.
     auto parts = fir::factory::Complex{builder, loc}.extractParts(arg);
     llvm::SmallVector<mlir::Value> args = {parts.first, parts.second};
     return genRuntimeCall("hypot", resultType, args);
   }
   llvm_unreachable("unexpected type in ABS argument");
 }
 
+// ASSOCIATED
+fir::ExtendedValue
+IntrinsicLibrary::genAssociated(mlir::Type resultType,
+                                llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 2);
+  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 (isAbsent(target))
+    return fir::factory::genIsAllocatedOrAssociatedTest(builder, loc, *pointer);
+
+  mlir::Value targetBox = builder.createBox(loc, target);
+  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.
+    auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
+                                                      fir::getBase(target));
+    auto absentBox = builder.create<fir::AbsentOp>(loc, targetBox.getType());
+    targetBox = builder.create<mlir::arith::SelectOp>(loc, isPresent, targetBox,
+                                                      absentBox);
+  }
+  mlir::Value pointerBoxRef =
+      fir::factory::getMutableIRBox(builder, loc, *pointer);
+  auto pointerBox = builder.create<fir::LoadOp>(loc, pointerBoxRef);
+  return Fortran::lower::genAssociated(builder, loc, pointerBox, targetBox);
+}
+
 // IAND
 mlir::Value IntrinsicLibrary::genIand(mlir::Type resultType,
                                       llvm::ArrayRef<mlir::Value> args) {
   assert(args.size() == 2);
   return builder.create<mlir::arith::AndIOp>(loc, args[0], args[1]);
 }
 
 // Compare two FIR values and return boolean result as i1.

flang/lib/Lower/Runtime.cpp

 //===-- Runtime.cpp -------------------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/Runtime.h"
 #include "flang/Lower/Bridge.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Todo.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
 #include "flang/Parser/parse-tree.h"
+#include "flang/Runtime/pointer.h"
 #include "flang/Runtime/stop.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/Debug.h"
 
 #define DEBUG_TYPE "flang-lower-runtime"
 
 using namespace Fortran::runtime;
 
void Fortran::lower::genPauseStatement(
     Fortran::lower::AbstractConverter &converter,
     const Fortran::parser::PauseStmt &) {
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   mlir::Location loc = converter.getCurrentLocation();
   mlir::FuncOp callee =
       fir::runtime::getRuntimeFunc<mkRTKey(PauseStatement)>(loc, builder);
   builder.create<fir::CallOp>(loc, callee, llvm::None);
 }
+
+mlir::Value Fortran::lower::genAssociated(fir::FirOpBuilder &builder,
+                                          mlir::Location loc,
+                                          mlir::Value pointer,
+                                          mlir::Value target) {
+  mlir::FuncOp func =
+      fir::runtime::getRuntimeFunc<mkRTKey(PointerIsAssociatedWith)>(loc,
+                                                                     builder);
+  llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+      builder, loc, func.getType(), pointer, target);
+  return builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}

flang/lib/Optimizer/Builder/BoxValue.cpp

 //===-- BoxValue.cpp ------------------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 //
 // Pretty printers for box values, etc.
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Optimizer/Builder/BoxValue.h"
+#include "flang/Optimizer/Builder/FIRBuilder.h"
 #include "mlir/IR/BuiltinTypes.h"
 #include "llvm/Support/Debug.h"
 
 #define DEBUG_TYPE "flang-box-value"
 
 mlir::Value fir::getBase(const fir::ExtendedValue &exv) {
   return exv.match([](const fir::UnboxedValue &x) { return x; },
                    [](const auto &x) { return x.getAddr(); });
return exv.match(
       },
       [](const auto &) { return mlir::Value{}; });
 }
 
 fir::ExtendedValue fir::substBase(const fir::ExtendedValue &exv,
                                   mlir::Value base) {
   return exv.match(
       [=](const fir::UnboxedValue &x) { return fir::ExtendedValue(base); },
-      [=](const fir::BoxValue &) -> fir::ExtendedValue {
-        llvm::report_fatal_error("TODO: substbase of BoxValue");
-      },
-      [=](const fir::MutableBoxValue &) -> fir::ExtendedValue {
-        llvm::report_fatal_error("TODO: substbase of MutableBoxValue");
-      },
       [=](const auto &x) { return fir::ExtendedValue(x.clone(base)); });
 }
 
 llvm::SmallVector<mlir::Value> fir::getTypeParams(const ExtendedValue &exv) {
   using RT = llvm::SmallVector<mlir::Value>;
   auto baseTy = fir::getBase(exv).getType();
   if (auto t = fir::dyn_cast_ptrEleTy(baseTy))
     baseTy = t;
bool fir::BoxValue::verify() const {
   if (!extents.empty() && !(isDerived() || isUnlimitedPolymorphic()))
     return false;
   if (!extents.empty() && extents.size() != rank())
     return false;
   if (isCharacter() && explicitParams.size() > 1)
     return false;
   return true;
 }
+
+/// Get exactly one extent for any array-like extended value, \p exv. If \p exv
+/// is not an array or has rank less then \p dim, the result will be a nullptr.
+mlir::Value fir::getExtentAtDimension(const fir::ExtendedValue &exv,
+                                      fir::FirOpBuilder &builder,
+                                      mlir::Location loc, unsigned dim) {
+  auto extents = fir::factory::getExtents(builder, loc, exv);
+  if (dim < extents.size())
+    return extents[dim];
+  return {};
+}

flang/test/Lower/Intrinsics/associated.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: associated_test
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>>{{.*}}, %[[arg1:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>{{.*}})
+subroutine associated_test(scalar, array)
+    real, pointer :: scalar, array(:)
+    real, target :: ziel
+    ! CHECK: %[[ziel:.*]] = fir.alloca f32 {bindc_name = "ziel"
+    ! CHECK: %[[scalar:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+    ! CHECK: %[[addr0:.*]] = fir.box_addr %[[scalar]] : (!fir.box<!fir.ptr<f32>>) -> !fir.ptr<f32>
+    ! CHECK: %[[addrToInt0:.*]] = fir.convert %[[addr0]]
+    ! CHECK: cmpi ne, %[[addrToInt0]], %c0{{.*}}
+    print *, associated(scalar)
+    ! CHECK: %[[array:.*]] = fir.load %[[arg1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    ! CHECK: %[[addr1:.*]] = fir.box_addr %[[array]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.ptr<!fir.array<?xf32>>
+    ! CHECK: %[[addrToInt1:.*]] = fir.convert %[[addr1]]
+    ! CHECK: cmpi ne, %[[addrToInt1]], %c0{{.*}}
+    print *, associated(array)
+    ! CHECK: %[[zbox0:.*]] = fir.embox %[[ziel]] : (!fir.ref<f32>) -> !fir.box<f32>
+    ! CHECK: %[[scalar:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+    ! CHECK: %[[sbox:.*]] = fir.convert %[[scalar]] : (!fir.box<!fir.ptr<f32>>) -> !fir.box<none>
+    ! CHECK: %[[zbox:.*]] = fir.convert %[[zbox0]] : (!fir.box<f32>) -> !fir.box<none>
+    ! CHECK: fir.call @_FortranAPointerIsAssociatedWith(%[[sbox]], %[[zbox]]) : (!fir.box<none>, !fir.box<none>) -> i1
+    print *, associated(scalar, ziel)
+  end subroutine
+  
+  subroutine test_func_results()
+    interface
+      function get_pointer()
+        real, pointer :: get_pointer(:) 
+      end function
+    end interface
+    ! CHECK: %[[result:.*]] = fir.call @_QPget_pointer() : () -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+    ! CHECK: fir.save_result %[[result]] to %[[box_storage:.*]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    ! CHECK: %[[box:.*]] = fir.load %[[box_storage]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.ptr<!fir.array<?xf32>>
+    ! CHECK: %[[addr_cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<!fir.array<?xf32>>) -> i64
+    ! CHECK:  arith.cmpi ne, %[[addr_cast]], %c0{{.*}} : i64
+    print *, associated(get_pointer())
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPtest_optional_target_1(
+  ! 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_8:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
+  ! CHECK:  %[[VAL_9:.*]] = fir.embox %[[VAL_1]](%[[VAL_8]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
+  ! CHECK:  %[[VAL_10:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.array<10xf32>>) -> i1
+  ! CHECK:  %[[VAL_11:.*]] = fir.absent !fir.box<!fir.array<10xf32>>
+  ! CHECK:  %[[VAL_12:.*]] = arith.select %[[VAL_10]], %[[VAL_9]], %[[VAL_11]] : !fir.box<!fir.array<10xf32>>
+  ! 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:  %[[VAL_15:.*]] = fir.convert %[[VAL_12]] : (!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.absent !fir.box<!fir.array<?xf32>>
+  ! CHECK:  %[[VAL_9:.*]] = arith.select %[[VAL_7]], %[[VAL_1]], %[[VAL_8]] : !fir.box<!fir.array<?xf32>>
+  ! 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:  %[[VAL_12:.*]] = fir.convert %[[VAL_9]] : (!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_7:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+  ! CHECK:  %[[VAL_8:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> i1
+  ! CHECK:  %[[VAL_9:.*]] = fir.absent !fir.box<!fir.ptr<!fir.array<?xf32>>>
+  ! CHECK:  %[[VAL_10:.*]] = arith.select %[[VAL_8]], %[[VAL_7]], %[[VAL_9]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+  ! 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:  %[[VAL_13:.*]] = fir.convert %[[VAL_10]] : (!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_7:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
+  ! CHECK:  %[[VAL_8:.*]] = fir.is_present %[[VAL_1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>) -> i1
+  ! CHECK:  %[[VAL_9:.*]] = fir.absent !fir.box<!fir.heap<!fir.array<?xf32>>>
+  ! CHECK:  %[[VAL_10:.*]] = arith.select %[[VAL_8]], %[[VAL_7]], %[[VAL_9]] : !fir.box<!fir.heap<!fir.array<?xf32>>>
+  ! 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:  %[[VAL_13:.*]] = fir.convert %[[VAL_10]] : (!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(:)
+    print *, associated(p, pointer_ziel)
+  ! CHECK:  %[[VAL_7:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+  ! CHECK:  %[[VAL_8:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+  ! CHECK:  %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
+  ! CHECK:  %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
+  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_9]], %[[VAL_10]]) : (!fir.box<none>, !fir.box<none>) -> i1
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QPtest_allocatable_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.heap<!fir.array<?xf32>>>> {fir.bindc_name = "allocatable_ziel", fir.target}) {
+  subroutine test_allocatable_target(p, allocatable_ziel)
+    real, pointer :: p(:)
+    real, allocatable, target :: allocatable_ziel(:)
+  ! CHECK:  %[[VAL_7:.*]] = fir.load %[[VAL_1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xf32>>>>
+  ! CHECK:  %[[VAL_8:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+  ! CHECK:  %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.box<none>
+  ! CHECK:  %[[VAL_10:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.heap<!fir.array<?xf32>>>) -> !fir.box<none>
+  ! CHECK:  fir.call @_FortranAPointerIsAssociatedWith(%[[VAL_9]], %[[VAL_10]]) : (!fir.box<none>, !fir.box<none>) -> i1
+    print *, associated(p, allocatable_ziel)
+  end subroutine

flang/test/Lower/derived-pointer-components.f90

+! Test lowering of pointer components
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+module pcomp
+    implicit none
+    type t
+      real :: x
+      integer :: i
+    end type
+    interface
+      subroutine takes_real_scalar(x)
+        real :: x
+      end subroutine
+      subroutine takes_char_scalar(x)
+        character(*) :: x
+      end subroutine
+      subroutine takes_derived_scalar(x)
+        import t
+        type(t) :: x
+      end subroutine
+      subroutine takes_real_array(x)
+        real :: x(:)
+      end subroutine
+      subroutine takes_char_array(x)
+        character(*) :: x(:)
+      end subroutine
+      subroutine takes_derived_array(x)
+        import t
+        type(t) :: x(:)
+      end subroutine
+      subroutine takes_real_scalar_pointer(x)
+        real, pointer :: x
+      end subroutine
+      subroutine takes_real_array_pointer(x)
+        real, pointer :: x(:)
+      end subroutine
+      subroutine takes_logical(x)
+        logical :: x
+      end subroutine
+    end interface
+  
+    type real_p0
+      real, pointer :: p
+    end type
+    type real_p1
+      real, pointer :: p(:)
+    end type
+    type cst_char_p0
+      character(10), pointer :: p
+    end type
+    type cst_char_p1
+      character(10), pointer :: p(:)
+    end type
+    type def_char_p0
+      character(:), pointer :: p
+    end type
+    type def_char_p1
+      character(:), pointer :: p(:)
+    end type
+    type derived_p0
+      type(t), pointer :: p
+    end type
+    type derived_p1
+      type(t), pointer :: p(:)
+    end type
+  
+    real, target :: real_target, real_array_target(100)
+    character(10), target :: char_target, char_array_target(100)
+  
+  contains
+  
+  ! -----------------------------------------------------------------------------
+  !            Test pointer component references
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QMpcompPref_scalar_real_p(
+  ! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>{{.*}}, %[[arg1:.*]]: !fir.ref<!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>{{.*}}, %[[arg2:.*]]: !fir.ref<!fir.array<100x!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>>{{.*}}, %[[arg3:.*]]: !fir.ref<!fir.array<100x!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>{{.*}}) {
+  subroutine ref_scalar_real_p(p0_0, p1_0, p0_1, p1_1)
+    type(real_p0) :: p0_0, p0_1(100)
+    type(real_p1) :: p1_0, p1_1(100)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p, !fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[arg0]], %[[fld]] : (!fir.ref<!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<f32>>>
+    ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+    ! CHECK: %[[addr:.*]] = fir.box_addr %[[load]] : (!fir.box<!fir.ptr<f32>>) -> !fir.ptr<f32>
+    ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<f32>) -> !fir.ref<f32>
+    ! CHECK: fir.call @_QPtakes_real_scalar(%[[cast]]) : (!fir.ref<f32>) -> ()
+    call takes_real_scalar(p0_0%p)
+  
+    ! CHECK: %[[p0_1_coor:.*]] = fir.coordinate_of %[[arg2]], %{{.*}} : (!fir.ref<!fir.array<100x!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>>, i64) -> !fir.ref<!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>
+    ! CHECK: %[[fld:.*]] = fir.field_index p, !fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_1_coor]], %[[fld]] : (!fir.ref<!fir.type<_QMpcompTreal_p0{p:!fir.box<!fir.ptr<f32>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<f32>>>
+    ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+    ! CHECK: %[[addr:.*]] = fir.box_addr %[[load]] : (!fir.box<!fir.ptr<f32>>) -> !fir.ptr<f32>
+    ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<f32>) -> !fir.ref<f32>
+    ! CHECK: fir.call @_QPtakes_real_scalar(%[[cast]]) : (!fir.ref<f32>) -> ()
+    call takes_real_scalar(p0_1(5)%p)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p, !fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[arg1]], %[[fld]] : (!fir.ref<!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[load]], %c0{{.*}} : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
+    ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64
+    ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] : i64
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[load]], %[[index]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, i64) -> !fir.ref<f32>
+    ! CHECK: fir.call @_QPtakes_real_scalar(%[[coor]]) : (!fir.ref<f32>) -> ()
+    call takes_real_scalar(p1_0%p(7))
+  
+    ! CHECK: %[[p1_1_coor:.*]] = fir.coordinate_of %[[arg3]], %{{.*}} : (!fir.ref<!fir.array<100x!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>>, i64) -> !fir.ref<!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>
+    ! CHECK: %[[fld:.*]] = fir.field_index p, !fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_1_coor]], %[[fld]] : (!fir.ref<!fir.type<_QMpcompTreal_p1{p:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    ! CHECK: %[[load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+    ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[load]], %c0{{.*}} : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
+    ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64
+    ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]] : i64
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[load]], %[[index]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, i64) -> !fir.ref<f32>
+    ! CHECK: fir.call @_QPtakes_real_scalar(%[[coor]]) : (!fir.ref<f32>) -> ()
+    call takes_real_scalar(p1_1(5)%p(7))
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMpcompPassign_scalar_real
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine assign_scalar_real_p(p0_0, p1_0, p0_1, p1_1)
+    type(real_p0) :: p0_0, p0_1(100)
+    type(real_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]]
+    ! CHECK: fir.store {{.*}} to %[[addr]]
+    p0_0%p = 1.
+  
+    ! CHECK: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]]
+    ! CHECK: fir.store {{.*}} to %[[addr]]
+    p0_1(5)%p = 2.
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], {{.*}}
+    ! CHECK: fir.store {{.*}} to %[[addr]]
+    p1_0%p(7) = 3.
+  
+    ! CHECK: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], {{.*}}
+    ! CHECK: fir.store {{.*}} to %[[addr]]
+    p1_1(5)%p(7) = 4.
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMpcompPref_scalar_cst_char_p
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine ref_scalar_cst_char_p(p0_0, p1_0, p0_1, p1_1)
+    type(cst_char_p0) :: p0_0, p0_1(100)
+    type(cst_char_p1) :: p1_0, p1_1(100)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]]
+    ! CHECK: %[[cast:.*]] = fir.convert %[[addr]]
+    ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %c10{{.*}}
+    ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]])
+    call takes_char_scalar(p0_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[addr:.*]] = fir.box_addr %[[box]]
+    ! CHECK: %[[cast:.*]] = fir.convert %[[addr]]
+    ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %c10{{.*}}
+    ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]])
+    call takes_char_scalar(p0_1(5)%p)
+  
+  
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}}
+    ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64
+    ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]]
+    ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[index]]
+    ! CHECK: %[[cast:.*]] = fir.convert %[[addr]]
+    ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %c10{{.*}}
+    ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]])
+    call takes_char_scalar(p1_0%p(7))
+  
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}}
+    ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64
+    ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]]
+    ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[index]]
+    ! CHECK: %[[cast:.*]] = fir.convert %[[addr]]
+    ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %c10{{.*}}
+    ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]])
+    call takes_char_scalar(p1_1(5)%p(7))
+  
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMpcompPref_scalar_def_char_p
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine ref_scalar_def_char_p(p0_0, p1_0, p0_1, p1_1)
+    type(def_char_p0) :: p0_0, p0_1(100)
+    type(def_char_p1) :: p1_0, p1_1(100)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]]
+    ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]]
+    ! CHECK-DAG: %[[cast:.*]] = fir.convert %[[addr]]
+    ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %[[len]]
+    ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]])
+    call takes_char_scalar(p0_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]]
+    ! CHECK-DAG: %[[addr:.*]] = fir.box_addr %[[box]]
+    ! CHECK-DAG: %[[cast:.*]] = fir.convert %[[addr]]
+    ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[cast]], %[[len]]
+    ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]])
+    call takes_char_scalar(p0_1(5)%p)
+  
+  
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]]
+    ! CHECK-DAG: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}}
+    ! CHECK-DAG: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64
+    ! CHECK-DAG: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]]
+    ! CHECK-DAG: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[index]]
+    ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr]], %[[len]]
+    ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]])
+    call takes_char_scalar(p1_0%p(7))
+  
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK-DAG: %[[len:.*]] = fir.box_elesize %[[box]]
+    ! CHECK-DAG: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}}
+    ! CHECK-DAG: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64
+    ! CHECK-DAG: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]]
+    ! CHECK-DAG: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[index]]
+    ! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr]], %[[len]]
+    ! CHECK: fir.call @_QPtakes_char_scalar(%[[boxchar]])
+    call takes_char_scalar(p1_1(5)%p(7))
+  
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMpcompPref_scalar_derived
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine ref_scalar_derived(p0_0, p1_0, p0_1, p1_1)
+    type(derived_p0) :: p0_0, p0_1(100)
+    type(derived_p1) :: p1_0, p1_1(100)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[fldx:.*]] = fir.field_index x
+    ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[fldx]]
+    ! CHECK: fir.call @_QPtakes_real_scalar(%[[addr]])
+    call takes_real_scalar(p0_0%p%x)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[fldx:.*]] = fir.field_index x
+    ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[box]], %[[fldx]]
+    ! CHECK: fir.call @_QPtakes_real_scalar(%[[addr]])
+    call takes_real_scalar(p0_1(5)%p%x)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}}
+    ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64
+    ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]]
+    ! CHECK: %[[elem:.*]] = fir.coordinate_of %[[box]], %[[index]]
+    ! CHECK: %[[fldx:.*]] = fir.field_index x
+    ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[elem]], %[[fldx]]
+    ! CHECK: fir.call @_QPtakes_real_scalar(%[[addr]])
+    call takes_real_scalar(p1_0%p(7)%x)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[box]], %c0{{.*}}
+    ! CHECK: %[[lb:.*]] = fir.convert %[[dims]]#0 : (index) -> i64
+    ! CHECK: %[[index:.*]] = arith.subi %c7{{.*}}, %[[lb]]
+    ! CHECK: %[[elem:.*]] = fir.coordinate_of %[[box]], %[[index]]
+    ! CHECK: %[[fldx:.*]] = fir.field_index x
+    ! CHECK: %[[addr:.*]] = fir.coordinate_of %[[elem]], %[[fldx]]
+    ! CHECK: fir.call @_QPtakes_real_scalar(%[[addr]])
+    call takes_real_scalar(p1_1(5)%p(7)%x)
+  
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !            Test passing pointer component references as pointers
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QMpcompPpass_real_p
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine pass_real_p(p0_0, p1_0, p0_1, p1_1)
+    type(real_p0) :: p0_0, p0_1(100)
+    type(real_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: fir.call @_QPtakes_real_scalar_pointer(%[[coor]])
+    call takes_real_scalar_pointer(p0_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.call @_QPtakes_real_scalar_pointer(%[[coor]])
+    call takes_real_scalar_pointer(p0_1(5)%p)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: fir.call @_QPtakes_real_array_pointer(%[[coor]])
+    call takes_real_array_pointer(p1_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.call @_QPtakes_real_array_pointer(%[[coor]])
+    call takes_real_array_pointer(p1_1(5)%p)
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !            Test usage in intrinsics where pointer aspect matters
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QMpcompPassociated_p
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine associated_p(p0_0, p1_0, p0_1, p1_1)
+    type(real_p0) :: p0_0, p0_1(100)
+    type(def_char_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: fir.box_addr %[[box]]
+    call takes_logical(associated(p0_0%p))
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: fir.box_addr %[[box]]
+    call takes_logical(associated(p0_1(5)%p))
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: fir.box_addr %[[box]]
+    call takes_logical(associated(p1_0%p))
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: %[[box:.*]] = fir.load %[[coor]]
+    ! CHECK: fir.box_addr %[[box]]
+    call takes_logical(associated(p1_1(5)%p))
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !            Test pointer assignment of components
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QMpcompPpassoc_real
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine passoc_real(p0_0, p1_0, p0_1, p1_1)
+    type(real_p0) :: p0_0, p0_1(100)
+    type(real_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    p0_0%p => real_target
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    p0_1(5)%p => real_target
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    p1_0%p => real_array_target
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    p1_1(5)%p => real_array_target
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMpcompPpassoc_char
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine passoc_char(p0_0, p1_0, p0_1, p1_1)
+    type(cst_char_p0) :: p0_0, p0_1(100)
+    type(def_char_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    p0_0%p => char_target
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    p0_1(5)%p => char_target
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    p1_0%p => char_array_target
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    p1_1(5)%p => char_array_target
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !            Test nullify of components
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QMpcompPnullify_test
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine nullify_test(p0_0, p1_0, p0_1, p1_1)
+    type(real_p0) :: p0_0, p0_1(100)
+    type(def_char_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    nullify(p0_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    nullify(p0_1(5)%p)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    nullify(p1_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    nullify(p1_1(5)%p)
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !            Test allocation
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QMpcompPallocate_real
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine allocate_real(p0_0, p1_0, p0_1, p1_1)
+    type(real_p0) :: p0_0, p0_1(100)
+    type(real_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(p0_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(p0_1(5)%p)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(p1_0%p(100))
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(p1_1(5)%p(100))
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMpcompPallocate_cst_char
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine allocate_cst_char(p0_0, p1_0, p0_1, p1_1)
+    type(cst_char_p0) :: p0_0, p0_1(100)
+    type(cst_char_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(p0_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(p0_1(5)%p)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(p1_0%p(100))
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(p1_1(5)%p(100))
+  end subroutine
+  
+  ! CHECK-LABEL: func @_QMpcompPallocate_def_char
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine allocate_def_char(p0_0, p1_0, p0_1, p1_1)
+    type(def_char_p0) :: p0_0, p0_1(100)
+    type(def_char_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(character(18)::p0_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(character(18)::p0_1(5)%p)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(character(18)::p1_0%p(100))
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    allocate(character(18)::p1_1(5)%p(100))
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !            Test deallocation
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QMpcompPdeallocate_real
+  ! CHECK-SAME: (%[[p0_0:.*]]: {{.*}}, %[[p1_0:.*]]: {{.*}}, %[[p0_1:.*]]: {{.*}}, %[[p1_1:.*]]: {{.*}})
+  subroutine deallocate_real(p0_0, p1_0, p0_1, p1_1)
+    type(real_p0) :: p0_0, p0_1(100)
+    type(real_p1) :: p1_0, p1_1(100)
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p0_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    deallocate(p0_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p0_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    deallocate(p0_1(5)%p)
+  
+    ! CHECK: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[p1_0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    deallocate(p1_0%p)
+  
+    ! CHECK-DAG: %[[coor0:.*]] = fir.coordinate_of %[[p1_1]], %{{.*}}
+    ! CHECK-DAG: %[[fld:.*]] = fir.field_index p
+    ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[coor0]], %[[fld]]
+    ! CHECK: fir.store {{.*}} to %[[coor]]
+    deallocate(p1_1(5)%p)
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !            Test a very long component
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK-LABEL: func @_QMpcompPvery_long
+  ! CHECK-SAME: (%[[x:.*]]: {{.*}})
+  subroutine very_long(x)
+    type t0
+      real :: f
+    end type
+    type t1
+      type(t0), allocatable :: e(:)
+    end type
+    type t2
+      type(t1) :: d(10)
+    end type
+    type t3
+      type(t2) :: c
+    end type
+    type t4
+      type(t3), pointer :: b
+    end type
+    type t5
+      type(t4) :: a
+    end type
+    type(t5) :: x(:, :, :, :, :)
+  
+    ! CHECK: %[[coor0:.*]] = fir.coordinate_of %[[x]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %{{.}}
+    ! CHECK-DAG: %[[flda:.*]] = fir.field_index a
+    ! CHECK-DAG: %[[fldb:.*]] = fir.field_index b
+    ! CHECK: %[[coor1:.*]] = fir.coordinate_of %[[coor0]], %[[flda]], %[[fldb]]
+    ! CHECK: %[[b_box:.*]] = fir.load %[[coor1]]
+    ! CHECK-DAG: %[[fldc:.*]] = fir.field_index c
+    ! CHECK-DAG: %[[fldd:.*]] = fir.field_index d
+    ! CHECK: %[[coor2:.*]] = fir.coordinate_of %[[b_box]], %[[fldc]], %[[fldd]]
+    ! CHECK: %[[index:.*]] = arith.subi %c6{{.*}}, %c1{{.*}} : i64
+    ! CHECK: %[[coor3:.*]] = fir.coordinate_of %[[coor2]], %[[index]]
+    ! CHECK: %[[flde:.*]] = fir.field_index e
+    ! CHECK: %[[coor4:.*]] = fir.coordinate_of %[[coor3]], %[[flde]]
+    ! CHECK: %[[e_box:.*]] = fir.load %[[coor4]]
+    ! CHECK: %[[edims:.*]]:3 = fir.box_dims %[[e_box]], %c0{{.*}}
+    ! CHECK: %[[lb:.*]] = fir.convert %[[edims]]#0 : (index) -> i64
+    ! CHECK: %[[index2:.*]] = arith.subi %c7{{.*}}, %[[lb]]
+    ! CHECK: %[[coor5:.*]] = fir.coordinate_of %[[e_box]], %[[index2]]
+    ! CHECK: %[[fldf:.*]] = fir.field_index f
+    ! CHECK: %[[coor6:.*]] = fir.coordinate_of %[[coor5]], %[[fldf:.*]]
+    ! CHECK: fir.load %[[coor6]] : !fir.ref<f32>
+    print *, x(1,2,3,4,5)%a%b%c%d(6)%e(7)%f
+  end subroutine
+  
+  ! -----------------------------------------------------------------------------
+  !            Test a recursive derived type reference
+  ! -----------------------------------------------------------------------------
+  
+  ! CHECK: func @_QMpcompPtest_recursive
+  ! CHECK-SAME: (%[[x:.*]]: {{.*}})
+  subroutine test_recursive(x)
+    type t
+      integer :: i
+      type(t), pointer :: next
+    end type
+    type(t) :: x
+  
+    ! CHECK: %[[fldNext1:.*]] = fir.field_index next
+    ! CHECK: %[[next1:.*]] = fir.coordinate_of %[[x]], %[[fldNext1]]
+    ! CHECK: %[[nextBox1:.*]] = fir.load %[[next1]]
+    ! CHECK: %[[fldNext2:.*]] = fir.field_index next
+    ! CHECK: %[[next2:.*]] = fir.coordinate_of %[[nextBox1]], %[[fldNext2]]
+    ! CHECK: %[[nextBox2:.*]] = fir.load %[[next2]]
+    ! CHECK: %[[fldNext3:.*]] = fir.field_index next
+    ! CHECK: %[[next3:.*]] = fir.coordinate_of %[[nextBox2]], %[[fldNext3]]
+    ! CHECK: %[[nextBox3:.*]] = fir.load %[[next3]]
+    ! CHECK: %[[fldi:.*]] = fir.field_index i
+    ! CHECK: %[[i:.*]] = fir.coordinate_of %[[nextBox3]], %[[fldi]]
+    ! CHECK: %[[nextBox3:.*]] = fir.load %[[i]] : !fir.ref<i32>
+    print *, x%next%next%next%i
+  end subroutine
+  
+  end module

flang/test/Lower/derived-types-kind-params.f90

+! Test lowering of derived type with kind parameters
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+module m
+    type t(k1, k2)
+      integer(4), kind :: k1 = 7
+      integer(8), kind :: k2
+      character(k1) :: c(k2)
+    end type
+  
+    type t2(k1, k2)
+      integer(4), kind :: k1
+      integer(8), kind :: k2
+      type(t(k1+3, k2+4)) :: at
+    end type
+  
+    type t3(k)
+      integer, kind :: k
+      type(t3(k)), pointer :: at3
+    end type
+  
+    type t4(k)
+      integer, kind :: k
+      real(-k) :: i
+    end type
+  
+  contains
+  
+  ! -----------------------------------------------------------------------------
+  !            Test mangling of derived type with kind parameters
+  ! -----------------------------------------------------------------------------
+  
+    ! CHECK-LABEL: func @_QMmPfoo
+    ! CHECK-SAME: !fir.ref<!fir.type<_QMmTtK7K12{c:!fir.array<12x!fir.char<1,?>>
+    subroutine foo(at)
+      type(t(k2=12)) :: at
+    end subroutine
+  
+    ! CHECK-LABEL: func @_QMmPfoo2
+    ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt2K12K13{at:!fir.type<_QMmTtK15K17{c:!fir.array<17x!fir.char<1,?>>}>}>>
+    subroutine foo2(at2)
+      type(t2(12, 13)) :: at2
+    end subroutine
+  
+    ! CHECK-LABEL: func @_QMmPfoo3
+    ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt3K7{at3:!fir.box<!fir.ptr<!fir.type<_QMmTt3K7>>>}>>
+    subroutine foo3(at3)
+      type(t3(7)) :: at3
+    end subroutine
+  
+    ! CHECK-LABEL: func @_QMmPfoo4
+    ! CHECK-SAME: !fir.ref<!fir.type<_QMmTt4KN4{i:f32}>>
+    subroutine foo4(at4)
+      type(t4(-4)) :: at4
+    end subroutine
+  end module