[flang] Lowering LOC intrinsic

[kkwli0]

Summary

This patch is to add the lowering of the LOC intrinsic.

[jeanPerier]

Thanks for working on this, looks great for data "x", see my suggestion to support procedures.

flang/lib/Lower/IntrinsicCall.cpp

883

Could you update https://github.com/llvm/llvm-project/blob/09f7554890026aa454a4e5fb2508b411084ac7e0/flang/lib/Evaluate/intrinsics.cpp#L577 table so that the argument name is also "x" for consistency ?

3764

This will probably no work when "x" is a procedure. I think "loc" extension has to work with procedures too (at least flang semantics accepts them).
Could you find a way to share the relevant parts of the the "genCLocOrCFunLoc" here https://github.com/llvm/llvm-project/blob/6ed85a62bdbc40a7d98205b2b3da1cb46120faf4/flang/lib/Lower/IntrinsicCall.cpp#L2684-L2695 with the loc implementation ?
The parts that gets the address should be similar.

[kkwli0]

flang/lib/Lower/IntrinsicCall.cpp

883

Will do.

3764

Good point. I missed the procedure case.

The advantage of the genCLocOrCFunLoc routine is that whether the argument is a procedure or not is passed in. loc intrinsic accepts both and getLoc needs some logic to determine if the incoming is fir.embox or fir.emboxproc assuming that the arg is already lowered to either. In order to share the portion of the code in genCLocOrCFunLoc, I did some re-arrangement of the assert statements.

[kkwli0]

Address review comments:

• sync up the argument keyword
• share code with genCLocOrCFunLoc

[kkwli0]

@jeanPerier Thanks for the review. Should I include the update of Intrinsics.md (i.e. remove LOC from the unsupported list) in this patch?

[jeanPerier]

In D138572#3947769, @kkwli0 wrote:

@jeanPerier Thanks for the review. Should I include the update of Intrinsics.md (i.e. remove LOC from the unsupported list) in this patch?

That is a good idea, yes. Thanks.
Looks good otherwise, thanks for addressing my comments.

[kkwli0]

In D138572#3948615, @jeanPerier wrote:

In D138572#3947769, @kkwli0 wrote:

@jeanPerier Thanks for the review. Should I include the update of Intrinsics.md (i.e. remove LOC from the unsupported list) in this patch?

That is a good idea, yes. Thanks.
Looks good otherwise, thanks for addressing my comments.

@jeanPerier Thanks a lot. I will include the change in Intrinsics.md in the commit.

flang/docs/Intrinsics.md

 validates the argument types and deduces the return types.
 This phase currently supports all the intrinsic procedures listed above but the ones in the table below.
 
 | Intrinsic Category | Intrinsic Procedures Lacking Support |
 | --- | --- |
 | Coarray intrinsic functions | IMAGE_INDEX, COSHAPE |
 | Object characteristic inquiry functions | ALLOCATED, ASSOCIATED, EXTENDS_TYPE_OF, IS_CONTIGUOUS, PRESENT, RANK, SAME_TYPE, STORAGE_SIZE |
 | Type inquiry intrinsic functions | BIT_SIZE, DIGITS, EPSILON, HUGE, KIND, MAXEXPONENT, MINEXPONENT, NEW_LINE, PRECISION, RADIX, RANGE, TINY|
-| Non-standard intrinsic functions | AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, DCMPLX, EQV, NEQV, INT8, JINT, JNINT, KNINT, LOC, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC |
+| Non-standard intrinsic functions | AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, DCMPLX, EQV, NEQV, INT8, JINT, JNINT, KNINT, QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, NUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR, IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC |
 | Intrinsic subroutines |MVBITS (elemental), CPU_TIME, DATE_AND_TIME, EVENT_QUERY, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, MOVE_ALLOC, RANDOM_INIT, RANDOM_NUMBER, RANDOM_SEED, SYSTEM_CLOCK |
 | Atomic intrinsic subroutines | ATOMIC_ADD |
 | Collective intrinsic subroutines | CO_REDUCE |
 
 
 ### Intrinsic Function Folding
 Fortran Constant Expressions can contain references to a certain number of
 intrinsic functions (see Fortran 2018 standard section 10.1.12 for more details).

flang/lib/Evaluate/intrinsics.cpp

static const IntrinsicInterface genericIntrinsicFunction[]{
     {"lge", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
         DefaultLogical},
     {"lgt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
         DefaultLogical},
     {"lle", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
         DefaultLogical},
     {"llt", {{"string_a", SameCharNoLen}, {"string_b", SameCharNoLen}},
         DefaultLogical},
-    {"loc", {{"loc_argument", Addressable, Rank::anyOrAssumedRank}},
-        SubscriptInt, Rank::scalar},
+    {"loc", {{"x", Addressable, Rank::anyOrAssumedRank}}, SubscriptInt,
+        Rank::scalar},
     {"log", {{"x", SameFloating}}, SameFloating},
     {"log10", {{"x", SameReal}}, SameReal},
     {"logical", {{"l", AnyLogical}, DefaultingKIND}, KINDLogical},
     {"log_gamma", {{"x", SameReal}}, SameReal},
     {"matmul",
         {{"matrix_a", AnyLogical, Rank::vector},
             {"matrix_b", AnyLogical, Rank::matrix}},
         ResultLogical, Rank::vector, IntrinsicClass::transformationalFunction},

flang/lib/Lower/IntrinsicCall.cpp

struct IntrinsicLibrary {
   mlir::Value genIor(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genIparity(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genIshft(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genIshftc(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genLbound(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genLeadz(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genLen(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genLenTrim(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genLoc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   template <typename Shift>
   mlir::Value genMask(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genMatmul(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genMaxloc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genMaxval(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genMerge(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genMergeBits(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genMinloc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
static constexpr IntrinsicHandler handlers[]{
      &I::genLen,
      {{{"string", asInquired}, {"kind", asValue}}},
      /*isElemental=*/false},
     {"len_trim", &I::genLenTrim},
     {"lge", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sge>},
     {"lgt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sgt>},
     {"lle", &I::genCharacterCompare<mlir::arith::CmpIPredicate::sle>},
     {"llt", &I::genCharacterCompare<mlir::arith::CmpIPredicate::slt>},
+    {"loc", &I::genLoc, {{{"x", asBox}}}, /*isElemental=*/false},
     {"maskl", &I::genMask<mlir::arith::ShLIOp>},
     {"maskr", &I::genMask<mlir::arith::ShRUIOp>},
     {"matmul",
      &I::genMatmul,
      {{{"matrix_a", asAddr}, {"matrix_b", asAddr}}},
      /*isElemental=*/false},
     {"max", &I::genExtremum<Extremum::Max, ExtremumBehavior::MinMaxss>},
     {"maxloc",
mlir::Value IntrinsicLibrary::genBtest(mlir::Type resultType,
   mlir::Type argType = args[0].getType();
   mlir::Value pos = builder.createConvert(loc, argType, args[1]);
   auto shift = builder.create<mlir::arith::ShRUIOp>(loc, args[0], pos);
   mlir::Value one = builder.createIntegerConstant(loc, argType, 1);
   auto res = builder.create<mlir::arith::AndIOp>(loc, shift, one);
   return builder.createConvert(loc, resultType, res);
 }
 
+static mlir::Value getAddrFromBox(fir::FirOpBuilder &builder,
+                                  mlir::Location loc, fir::ExtendedValue arg,
+                                  bool isFunc) {
+  mlir::Value argValue = fir::getBase(arg);
+  mlir::Value addr{nullptr};
+  if (isFunc) {
+    auto funcTy = argValue.getType().cast<fir::BoxProcType>().getEleTy();
+    addr = builder.create<fir::BoxAddrOp>(loc, funcTy, argValue);
+  } else {
+    const auto *box = arg.getBoxOf<fir::BoxValue>();
+    addr = builder.create<fir::BoxAddrOp>(loc, box->getMemTy(),
+                                          fir::getBase(*box));
+  }
+  return addr;
+}
+
 static fir::ExtendedValue
 genCLocOrCFunLoc(fir::FirOpBuilder &builder, mlir::Location loc,
                  mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args,
                  bool isFunc = false) {
   assert(args.size() == 1);
   mlir::Value res = builder.create<fir::AllocaOp>(loc, resultType);
   mlir::Value resAddr =
       fir::factory::genCPtrOrCFunptrAddr(builder, loc, res, resultType);
-  mlir::Value argAddr;
-  if (isFunc) {
-    mlir::Value argValue = fir::getBase(args[0]);
-    assert(argValue.getType().isa<fir::BoxProcType>() &&
-           "c_funloc argument must have been lowered to a fir.boxproc");
-    auto funcTy = argValue.getType().cast<fir::BoxProcType>().getEleTy();
-    argAddr = builder.create<fir::BoxAddrOp>(loc, funcTy, argValue);
-  } else {
-    const auto *box = args[0].getBoxOf<fir::BoxValue>();
-    assert(box && "c_loc argument must have been lowered to a fir.box");
-    argAddr = builder.create<fir::BoxAddrOp>(loc, box->getMemTy(),
-                                             fir::getBase(*box));
-  }
+  assert(fir::isa_box_type(fir::getBase(args[0]).getType()) &&
+         "argument must have been lowered to box type");
+  mlir::Value argAddr = getAddrFromBox(builder, loc, args[0], isFunc);
   mlir::Value argAddrVal = builder.createConvert(
       loc, fir::unwrapRefType(resAddr.getType()), argAddr);
   builder.create<fir::StoreOp>(loc, argAddrVal, resAddr);
   return res;
 }
 
 /// C_ASSOCIATED
 static fir::ExtendedValue

 IntrinsicLibrary::genCharacterCompare(mlir::Type resultType,
                                       llvm::ArrayRef<fir::ExtendedValue> args) {
   assert(args.size() == 2);
   return fir::runtime::genCharCompare(
       builder, loc, pred, fir::getBase(args[0]), fir::getLen(args[0]),
       fir::getBase(args[1]), fir::getLen(args[1]));
 }
 
+// LOC
+fir::ExtendedValue
+IntrinsicLibrary::genLoc(mlir::Type resultType,
+                         llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 1);
+  mlir::Value argValue = fir::getBase(args[0]);
+  assert(fir::isa_box_type(argValue.getType()) &&
+         "argument must have been lowered to box type");
+  bool isFunc = argValue.getType().isa<fir::BoxProcType>();
+  mlir::Value argAddr = getAddrFromBox(builder, loc, args[0], isFunc);
+  return builder.createConvert(loc, fir::unwrapRefType(resultType), argAddr);
+}
+
 // MASKL, MASKR
 template <typename Shift>
 mlir::Value IntrinsicLibrary::genMask(mlir::Type resultType,
                                       llvm::ArrayRef<mlir::Value> args) {
   assert(args.size() == 2);
 
   mlir::Value zero = builder.createIntegerConstant(loc, resultType, 0);
   mlir::Value ones = builder.createIntegerConstant(loc, resultType, -1);

flang/test/Lower/Intrinsics/loc.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s
+
+! Test LOC intrinsic
+
+! CHECK-LABEL: func.func @_QPloc_scalar() {
+subroutine loc_scalar()
+  integer(8) :: p
+  integer :: x
+  p = loc(x)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[x:.*]] = fir.alloca i32 {{.*}}
+! CHECK: %[[xbox:.*]] = fir.embox %[[x]] : (!fir.ref<i32>) -> !fir.box<i32>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xbox]] : (!fir.box<i32>) -> !fir.ref<i32>
+! CHECK: %[[xaddrval:.*]] = fir.convert %[[xaddr]] : (!fir.ref<i32>) -> i64
+! CHECK: fir.store %[[xaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_char() {
+subroutine loc_char()
+  integer(8) :: p
+  character(5) :: x = "abcde"
+  p = loc(x)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[x:.*]] = fir.address_of(@_QFloc_charEx) : !fir.ref<!fir.char<1,5>>
+! CHECK: %[[xbox:.*]] = fir.embox %[[x]] : (!fir.ref<!fir.char<1,5>>) -> !fir.box<!fir.char<1,5>>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xbox]] : (!fir.box<!fir.char<1,5>>) -> !fir.ref<!fir.char<1,5>>
+! CHECK: %[[xaddrval:.*]] = fir.convert %[[xaddr]] : (!fir.ref<!fir.char<1,5>>) -> i64
+! CHECK: fir.store %[[xaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_substring() {
+subroutine loc_substring()
+  integer(8) :: p
+  character(5) :: x = "abcde"
+  p = loc(x(2:))
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[x:.*]] = fir.address_of(@_QFloc_substringEx) : !fir.ref<!fir.char<1,5>>
+! CHECK: %[[sslb:.*]] = arith.constant 2 : i64
+! CHECK: %[[ssub:.*]] = arith.constant 5 : i64
+! CHECK: %[[sslbidx:.*]] = fir.convert %[[sslb]] : (i64) -> index
+! CHECK: %[[ssubidx:.*]] = fir.convert %[[ssub]] : (i64) -> index
+! CHECK: %[[one:.*]] = arith.constant 1 : index
+! CHECK: %[[lboffset:.*]] = arith.subi %[[sslbidx]], %c1 : index
+! CHECK: %[[xarr:.*]] = fir.convert %[[x]] : (!fir.ref<!fir.char<1,5>>) -> !fir.ref<!fir.array<5x!fir.char<1>>>
+! CHECK: %[[xarrcoord:.*]] = fir.coordinate_of %[[xarr]], %[[lboffset]] : (!fir.ref<!fir.array<5x!fir.char<1>>>, index) -> !fir.ref<!fir.char<1>>
+! CHECK: %[[xss:.*]] = fir.convert %[[xarrcoord]] : (!fir.ref<!fir.char<1>>) -> !fir.ref<!fir.char<1,?>>
+! CHECK: %[[rng:.*]] = arith.subi %[[ssubidx]], %[[sslbidx]] : index
+! CHECK: %[[rngp1:.*]] = arith.addi %[[rng]], %[[one]] : index
+! CHECK: %[[zero:.*]] = arith.constant 0 : index
+! CHECK: %[[cmpval:.*]] = arith.cmpi slt, %[[rngp1]], %[[zero]] : index
+! CHECK: %[[sltval:.*]] = arith.select %[[cmpval]], %[[zero]], %[[rngp1]] : index
+! CHECK: %[[xssbox:.*]] = fir.embox %[[xss]] typeparams %[[sltval]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+! CHECK: %[[xssaddr:.*]] = fir.box_addr %[[xssbox]] : (!fir.box<!fir.char<1,?>>) -> !fir.ref<!fir.char<1,?>>
+! CHECK: %[[xssaddrval:.*]] = fir.convert %[[xssaddr]] : (!fir.ref<!fir.char<1,?>>) -> i64
+! CHECK: fir.store %[[xssaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_array() {
+subroutine loc_array
+  integer(8) :: p
+  integer :: x(10)
+  p = loc(x)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[ten:.*]] = arith.constant 10 : index
+! CHECK: %[[x:.*]] = fir.alloca !fir.array<10xi32> {{.*}}
+! CHECK: %[[xshp:.*]] = fir.shape %[[ten]] : (index) -> !fir.shape<1>
+! CHECK: %[[xbox:.*]] = fir.embox %[[x]](%[[xshp]]) : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xi32>>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xbox]] : (!fir.box<!fir.array<10xi32>>) -> !fir.ref<!fir.array<10xi32>>
+! CHECK: %[[xaddrval:.*]] = fir.convert %[[xaddr]] : (!fir.ref<!fir.array<10xi32>>) -> i64
+! CHECK: fir.store %[[xaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_chararray() {
+subroutine loc_chararray()
+  integer(8) :: p
+  character(5) :: x(2)
+  p = loc(x)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[two:.*]] = arith.constant 2 : index
+! CHECK: %[[x:.*]] = fir.alloca !fir.array<2x!fir.char<1,5>> {{.*}}
+! CHECK: %[[xshp:.*]] = fir.shape %[[two]] : (index) -> !fir.shape<1>
+! CHECK: %[[xbox:.*]] = fir.embox %[[x]](%[[xshp]]) : (!fir.ref<!fir.array<2x!fir.char<1,5>>>, !fir.shape<1>) -> !fir.box<!fir.array<2x!fir.char<1,5>>>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xbox]] : (!fir.box<!fir.array<2x!fir.char<1,5>>>) -> !fir.ref<!fir.array<2x!fir.char<1,5>>>
+! CHECK: %[[xaddrval:.*]] = fir.convert %[[xaddr]] : (!fir.ref<!fir.array<2x!fir.char<1,5>>>) -> i64
+! CHECK: fir.store %[[xaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_arrayelement() {
+subroutine loc_arrayelement()
+  integer(8) :: p
+  integer :: x(10)
+  p = loc(x(7))
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[x:.*]] = fir.alloca !fir.array<10xi32> {{.*}}
+! CHECK: %[[idx:.*]] = arith.constant 7 : i64
+! CHECK: %[[lb:.*]] = arith.constant 1 : i64
+! CHECK: %[[offset:.*]] = arith.subi %[[idx]], %[[lb]] : i64
+! CHECK: %[[xelemcoord:.*]] = fir.coordinate_of %[[x]], %[[offset]] : (!fir.ref<!fir.array<10xi32>>, i64) -> !fir.ref<i32>
+! CHECK: %[[xelembox:.*]] = fir.embox %[[xelemcoord]] : (!fir.ref<i32>) -> !fir.box<i32>
+! CHECK: %[[xelemaddr:.*]] = fir.box_addr %[[xelembox]] : (!fir.box<i32>) -> !fir.ref<i32>
+! CHECK: %[[xelemaddrval:.*]] = fir.convert %[[xelemaddr]] : (!fir.ref<i32>) -> i64
+! CHECK: fir.store %[[xelemaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_arraysection(
+! CHECK-SAME: %[[arg:.*]]: !fir.ref<i32> {{.*}}) {
+subroutine loc_arraysection(i)
+  integer(8) :: p
+  integer :: i
+  real :: x(11)
+  p = loc(x(i:))
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[eleven:.*]] = arith.constant 11 : index
+! CHECK: %[[x:.*]] = fir.alloca !fir.array<11xf32> {{.*}}
+! CHECK: %[[one:.*]] = arith.constant 1 : index
+! CHECK: %[[i:.*]] = fir.load %[[arg]] : !fir.ref<i32>
+! CHECK: %[[il:.*]] = fir.convert %[[i]] : (i32) -> i64
+! CHECK: %[[iidx:.*]] = fir.convert %[[il]] : (i64) -> index
+! CHECK: %[[onel:.*]] = arith.constant 1 : i64
+! CHECK: %[[stpidx:.*]] = fir.convert %[[onel]] : (i64) -> index
+! CHECK: %[[xrng:.*]] = arith.addi %[[one]], %[[eleven]] : index
+! CHECK: %[[xub:.*]] = arith.subi %[[xrng]], %[[one]] : index
+! CHECK: %[[xshp:.*]] = fir.shape %[[eleven]] : (index) -> !fir.shape<1>
+! CHECK: %[[xslice:.*]] = fir.slice %[[iidx]], %[[xub]], %[[stpidx]] : (index, index, index) -> !fir.slice<1>
+! CHECK: %[[xbox:.*]] = fir.embox %[[x]](%[[xshp]]) [%[[xslice]]] : (!fir.ref<!fir.array<11xf32>>, !fir.shape<1>, !fir.slice<1>) -> !fir.box<!fir.array<?xf32>>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xbox]] : (!fir.box<!fir.array<?xf32>>) -> !fir.ref<!fir.array<?xf32>>
+! CHECK: %[[xaddrval:.*]] = fir.convert %[[xaddr]] : (!fir.ref<!fir.array<?xf32>>) -> i64
+! CHECK: fir.store %[[xaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_non_save_pointer_scalar() {
+subroutine loc_non_save_pointer_scalar()
+  integer(8) :: p
+  real, pointer :: x
+  real, target :: t
+  x => t
+  p = loc(x)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[t:.*]] = fir.alloca f32 {{.*}}
+! CHECK: %2 = fir.alloca !fir.box<!fir.ptr<f32>> {{.*}}
+! CHECK: %[[xa:.*]] = fir.alloca !fir.ptr<f32> {{.*}}
+! CHECK: %[[zero:.*]] = fir.zero_bits !fir.ptr<f32>
+! CHECK: fir.store %[[zero]] to %[[xa]] : !fir.ref<!fir.ptr<f32>>
+! CHECK: %[[taddr:.*]] = fir.convert %[[t]] : (!fir.ref<f32>) -> !fir.ptr<f32>
+! CHECK: fir.store %[[taddr]] to %[[xa]] : !fir.ref<!fir.ptr<f32>>
+! CHECK: %[[x:.*]] = fir.load %[[xa]] : !fir.ref<!fir.ptr<f32>>
+! CHECK: %[[xbox:.*]] = fir.embox %[[x]] : (!fir.ptr<f32>) -> !fir.box<f32>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xbox]] : (!fir.box<f32>) -> !fir.ref<f32>
+! CHECK: %[[xaddrval:.*]] = fir.convert %[[xaddr]] : (!fir.ref<f32>) -> i64
+! CHECK: fir.store %[[xaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_save_pointer_scalar() {
+subroutine loc_save_pointer_scalar()
+  integer :: p
+  real, pointer, save :: x
+  p = loc(x)
+! CHECK: %[[p:.*]] = fir.alloca i32 {{.*}}
+! CHECK: %[[x:.*]] = fir.address_of(@_QFloc_save_pointer_scalarEx) : !fir.ref<!fir.box<!fir.ptr<f32>>>
+! CHECK: %[[xref:.*]] = fir.load %[[x]] : !fir.ref<!fir.box<!fir.ptr<f32>>>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xref]] : (!fir.box<!fir.ptr<f32>>) -> !fir.ptr<f32>
+! CHECK: %[[xbox:.*]] = fir.embox %[[xaddr]] : (!fir.ptr<f32>) -> !fir.box<f32>
+! CHECK: %[[xaddr2:.*]] = fir.box_addr %[[xbox]] : (!fir.box<f32>) -> !fir.ref<f32>
+! CHECK: %[[xaddr2vall:.*]] = fir.convert %[[xaddr2]] : (!fir.ref<f32>) -> i64
+! CHECK: %[[xaddr2val:.*]] = fir.convert %[[xaddr2vall]] : (i64) -> i32
+! CHECK: fir.store %[[xaddr2val]] to %[[p]] : !fir.ref<i32>
+end
+
+! CHECK-LABEL: func.func @_QPloc_derived_type() {
+subroutine loc_derived_type
+  integer(8) :: p
+  type dt
+    integer :: i
+  end type
+  type(dt) :: xdt
+  p = loc(xdt)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[xdt:.*]] = fir.alloca !fir.type<_QFloc_derived_typeTdt{i:i32}> {{.*}}
+! CHECK: %[[xdtbox:.*]] = fir.embox %[[xdt]] : (!fir.ref<!fir.type<_QFloc_derived_typeTdt{i:i32}>>) -> !fir.box<!fir.type<_QFloc_derived_typeTdt{i:i32}>>
+! CHECK: %[[xdtaddr:.*]] = fir.box_addr %[[xdtbox]] : (!fir.box<!fir.type<_QFloc_derived_typeTdt{i:i32}>>) -> !fir.ref<!fir.type<_QFloc_derived_typeTdt{i:i32}>>
+! CHECK: %[[xdtaddrval:.*]] = fir.convert %[[xdtaddr]] : (!fir.ref<!fir.type<_QFloc_derived_typeTdt{i:i32}>>) -> i64
+! CHECK: fir.store %[[xdtaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_pointer_array() {
+subroutine loc_pointer_array
+  integer(8) :: p
+  integer, pointer :: x(:)
+  p = loc(x)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[x:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?xi32>>> {{.*}}
+! CHECK: %2 = fir.zero_bits !fir.ptr<!fir.array<?xi32>>
+! CHECK: %[[zero:.*]] = arith.constant 0 : index
+! CHECK: %[[xshp:.*]] = fir.shape %[[zero]] : (index) -> !fir.shape<1>
+! CHECK: %[[xbox0:.*]] = fir.embox %2(%[[xshp]]) : (!fir.ptr<!fir.array<?xi32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xi32>>>
+! CHECK: fir.store %[[xbox0]] to %[[x]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>
+! CHECK: %[[xbox:.*]] = fir.load %[[x]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xi32>>>>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xbox]] : (!fir.box<!fir.ptr<!fir.array<?xi32>>>) -> !fir.ptr<!fir.array<?xi32>>
+! CHECK: %[[xaddrval:.*]] = fir.convert %[[xaddr]] : (!fir.ptr<!fir.array<?xi32>>) -> i64
+! CHECK: fir.store %[[xaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPloc_allocatable_array() {
+subroutine loc_allocatable_array
+  integer(8) :: p
+  integer, allocatable :: x(:)
+  p = loc(x)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %1 = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> {{.*}}
+! CHECK: %[[stg:.*]] = fir.alloca !fir.heap<!fir.array<?xi32>> {{.*}}
+! CHECK: %[[lb:.*]] = fir.alloca index {{.*}}
+! CHECK: %[[ext:.*]] = fir.alloca index {{.*}}
+! CHECK: %[[zstg:.*]] = fir.zero_bits !fir.heap<!fir.array<?xi32>>
+! CHECK: fir.store %[[zstg]] to %[[stg]] : !fir.ref<!fir.heap<!fir.array<?xi32>>>
+! CHECK: %[[lbval:.*]] = fir.load %[[lb]] : !fir.ref<index>
+! CHECK: %[[extval:.*]] = fir.load %[[ext]] : !fir.ref<index>
+! CHECK: %[[stgaddr:.*]] = fir.load %[[stg]] : !fir.ref<!fir.heap<!fir.array<?xi32>>>
+! CHECK: %[[ss:.*]] = fir.shape_shift %[[lbval]], %[[extval]] : (index, index) -> !fir.shapeshift<1>
+! CHECK: %[[xbox:.*]] = fir.embox %[[stgaddr]](%[[ss]]) : (!fir.heap<!fir.array<?xi32>>, !fir.shapeshift<1>) -> !fir.box<!fir.array<?xi32>>
+! CHECK: %[[xaddr:.*]] = fir.box_addr %[[xbox]] : (!fir.box<!fir.array<?xi32>>) -> !fir.ref<!fir.array<?xi32>>
+! CHECK: %[[xaddrval:.*]] = fir.convert %[[xaddr]] : (!fir.ref<!fir.array<?xi32>>) -> i64
+! CHECK: fir.store %[[xaddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPtest_external() {
+subroutine test_external()
+  integer(8) :: p
+  integer, external :: f
+  p = loc(x=f)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[f:.*]] = fir.address_of(@_QPf) : () -> i32
+! CHECK: %[[fbox:.*]] = fir.emboxproc %[[f]] : (() -> i32) -> !fir.boxproc<() -> i32>
+! CHECK: %[[faddr:.*]] = fir.box_addr %[[fbox]] : (!fir.boxproc<() -> i32>) -> (() -> i32)
+! CHECK: %[[faddrval:.*]] = fir.convert %[[faddr]] : (() -> i32) -> i64
+! CHECK: fir.store %[[faddrval]] to %[[p]] : !fir.ref<i64>
+end
+
+! CHECK-LABEL: func.func @_QPtest_proc() {
+subroutine test_proc()
+  integer(8) :: p
+  procedure() :: g
+  p = loc(x=g)
+! CHECK: %[[p:.*]] = fir.alloca i64 {{.*}}
+! CHECK: %[[g:.*]] = fir.address_of(@_QPg) : () -> ()
+! CHECK: %[[gbox:.*]] = fir.emboxproc %[[g]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK: %[[gaddr:.*]] = fir.box_addr %[[gbox]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[gaddrval:.*]] = fir.convert %[[gaddr]] : (() -> ()) -> i64
+! CHECK: fir.store %[[gaddrval]] to %[[p]] : !fir.ref<i64>
+end