From 8c77c011c193eba6f0c45cbf5cba6ea7d6a147fe Mon Sep 17 00:00:00 2001 From: Peixin Qiao Date: Fri, 13 Jan 2023 20:40:51 +0800 Subject: [PATCH] [flang] Initial support of allocate statement with source Support allocate statement with source in runtime version. The source expression is evaluated only once for each allocate statement. When the source expression has shape-spec, uses it for bounds. Otherwise, get the bounds from the source expression. Get the length if the source expression has deferred length parameter. Reviewed By: clementval, jeanPerier Differential Revision: https://reviews.llvm.org/D137812 --- flang/include/flang/Runtime/assign.h | 26 +- flang/lib/Lower/Allocatable.cpp | 151 ++++++--- flang/runtime/allocatable.cpp | 20 +- flang/runtime/assign.cpp | 10 +- flang/runtime/assign.h | 30 ++ flang/runtime/pointer.cpp | 19 +- flang/test/Lower/allocate-source-allocatables.f90 | 369 ++++++++++++++++++++++ flang/test/Lower/allocate-source-pointers.f90 | 356 +++++++++++++++++++++ 8 files changed, 919 insertions(+), 62 deletions(-) create mode 100644 flang/runtime/assign.h create mode 100644 flang/test/Lower/allocate-source-allocatables.f90 create mode 100644 flang/test/Lower/allocate-source-pointers.f90 diff --git a/flang/include/flang/Runtime/assign.h b/flang/include/flang/Runtime/assign.h index 141a0b6..fe06567 100644 --- a/flang/include/flang/Runtime/assign.h +++ b/flang/include/flang/Runtime/assign.h @@ -6,15 +6,15 @@ // //===----------------------------------------------------------------------===// -// External and internal APIs for data assignment (both intrinsic assignment -// and TBP defined generic ASSIGNMENT(=)). Should be called by lowering -// for any assignments possibly needing special handling. Intrinsic assignment -// to non-allocatable variables whose types are intrinsic need not come through -// here (though they may do so). Assignments to allocatables, and assignments -// whose types may be polymorphic or are monomorphic and of derived types with -// finalization, allocatable components, or components with type-bound defined -// assignments, in the original type or the types of its non-pointer components -// (recursively) must arrive here. +// External APIs for data assignment (both intrinsic assignment and TBP defined +// generic ASSIGNMENT(=)). Should be called by lowering for any assignments +// possibly needing special handling. Intrinsic assignment to non-allocatable +// variables whose types are intrinsic need not come through here (though they +// may do so). Assignments to allocatables, and assignments whose types may be +// polymorphic or are monomorphic and of derived types with finalization, +// allocatable components, or components with type-bound defined assignments, in +// the original type or the types of its non-pointer components (recursively) +// must arrive here. // // Non-type-bound generic INTERFACE ASSIGNMENT(=) is resolved in semantics and // need not be handled here in the runtime; ditto for type conversions on @@ -27,14 +27,6 @@ namespace Fortran::runtime { class Descriptor; -class Terminator; - -// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or -// type-bound (only!) defined assignment (10.2.1.4), as appropriate. Performs -// finalization, scalar expansion, & allocatable (re)allocation as needed. -// Does not perform intrinsic assignment implicit type conversion. Both -// descriptors must be initialized. Recurses as needed to handle components. -void Assign(Descriptor &, const Descriptor &, Terminator &); extern "C" { // API for lowering assignment diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp index c374488..5fb8c8d 100644 --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -183,6 +183,29 @@ static mlir::Value genRuntimeAllocate(fir::FirOpBuilder &builder, return builder.create(loc, callee, operands).getResult(0); } +/// Generate a sequence of runtime calls to allocate memory and assign with the +/// \p source. +static mlir::Value genRuntimeAllocateSource(fir::FirOpBuilder &builder, + mlir::Location loc, + const fir::MutableBoxValue &box, + fir::ExtendedValue source, + ErrorManager &errorManager) { + mlir::func::FuncOp callee = + box.isPointer() + ? fir::runtime::getRuntimeFunc( + loc, builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + llvm::SmallVector args{ + box.getAddr(), fir::getBase(source), + errorManager.hasStat, errorManager.errMsgAddr, + errorManager.sourceFile, errorManager.sourceLine}; + llvm::SmallVector operands; + for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs())) + operands.emplace_back(builder.createConvert(loc, snd, fst)); + return builder.create(loc, callee, operands).getResult(0); +} + /// Generate a runtime call to deallocate memory. static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder, mlir::Location loc, @@ -255,8 +278,11 @@ public: visitAllocateOptions(); lowerAllocateLengthParameters(); errorManager.init(converter, loc, statExpr, errMsgExpr); - if (sourceExpr || moldExpr) - TODO(loc, "lower MOLD/SOURCE expr in allocate"); + Fortran::lower::StatementContext stmtCtx; + if (sourceExpr) + sourceExv = converter.genExprBox(loc, *sourceExpr, stmtCtx); + if (moldExpr) + TODO(loc, "lower MOLD expr in allocate"); mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint(); for (const auto &allocation : std::get>(stmt.t)) @@ -393,45 +419,13 @@ private: } // Generate a sequence of runtime calls. errorManager.genStatCheck(builder, loc); - if (box.isPointer()) { - // For pointers, the descriptor may still be uninitialized (see Fortran - // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor - // with initialized rank, types and attributes. Initialize the descriptor - // here to ensure these constraints are fulfilled. - mlir::Value nullPointer = fir::factory::createUnallocatedBox( - builder, loc, box.getBoxTy(), box.nonDeferredLenParams()); - builder.create(loc, nullPointer, box.getAddr()); - } else { - assert(box.isAllocatable() && "must be an allocatable"); - // For allocatables, sync the MutableBoxValue and descriptor before the - // calls in case it is tracked locally by a set of variables. - fir::factory::getMutableIRBox(builder, loc, box); - } + genAllocateObjectInit(box); if (alloc.hasCoarraySpec()) TODO(loc, "coarray allocation"); if (alloc.type.IsPolymorphic()) genSetType(alloc, box, loc); genSetDeferredLengthParameters(alloc, box); - // Set bounds for arrays - mlir::Type idxTy = builder.getIndexType(); - mlir::Type i32Ty = builder.getIntegerType(32); - Fortran::lower::StatementContext stmtCtx; - for (const auto &iter : llvm::enumerate(alloc.getShapeSpecs())) { - mlir::Value lb; - const auto &bounds = iter.value().t; - if (const std::optional &lbExpr = - std::get<0>(bounds)) - lb = fir::getBase(converter.genExprValue( - loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx)); - else - lb = builder.createIntegerConstant(loc, idxTy, 1); - mlir::Value ub = fir::getBase(converter.genExprValue( - loc, Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx)); - mlir::Value dimIndex = - builder.createIntegerConstant(loc, i32Ty, iter.index()); - // Runtime call - genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub); - } + genAllocateObjectBounds(alloc, box); mlir::Value stat = genRuntimeAllocate(builder, loc, box, errorManager); fir::factory::syncMutableBoxFromIRBox(builder, loc, box); errorManager.assignStat(builder, loc, stat); @@ -478,8 +472,87 @@ private: TODO(loc, "derived type length parameters in allocate"); } - void genSourceAllocation(const Allocation &, const fir::MutableBoxValue &) { - TODO(loc, "SOURCE allocation"); + void genAllocateObjectInit(const fir::MutableBoxValue &box) { + if (box.isPointer()) { + // For pointers, the descriptor may still be uninitialized (see Fortran + // 2018 19.5.2.2). The allocation runtime needs to be given a descriptor + // with initialized rank, types and attributes. Initialize the descriptor + // here to ensure these constraints are fulfilled. + mlir::Value nullPointer = fir::factory::createUnallocatedBox( + builder, loc, box.getBoxTy(), box.nonDeferredLenParams()); + builder.create(loc, nullPointer, box.getAddr()); + } else { + assert(box.isAllocatable() && "must be an allocatable"); + // For allocatables, sync the MutableBoxValue and descriptor before the + // calls in case it is tracked locally by a set of variables. + fir::factory::getMutableIRBox(builder, loc, box); + } + } + + void genAllocateObjectBounds(const Allocation &alloc, + const fir::MutableBoxValue &box) { + // Set bounds for arrays + mlir::Type idxTy = builder.getIndexType(); + mlir::Type i32Ty = builder.getIntegerType(32); + Fortran::lower::StatementContext stmtCtx; + for (const auto &iter : llvm::enumerate(alloc.getShapeSpecs())) { + mlir::Value lb; + const auto &bounds = iter.value().t; + if (const std::optional &lbExpr = + std::get<0>(bounds)) + lb = fir::getBase(converter.genExprValue( + loc, Fortran::semantics::GetExpr(*lbExpr), stmtCtx)); + else + lb = builder.createIntegerConstant(loc, idxTy, 1); + mlir::Value ub = fir::getBase(converter.genExprValue( + loc, Fortran::semantics::GetExpr(std::get<1>(bounds)), stmtCtx)); + mlir::Value dimIndex = + builder.createIntegerConstant(loc, i32Ty, iter.index()); + // Runtime call + genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub); + } + if (sourceExpr && sourceExpr->Rank() > 0 && + alloc.getShapeSpecs().size() == 0) { + // If the alloc object does not have shape list, get the bounds from the + // source expression. + mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1); + const auto *sourceBox = sourceExv.getBoxOf(); + assert(sourceBox && "source expression should be lowered to one box"); + for (int i = 0; i < sourceExpr->Rank(); ++i) { + auto dimVal = builder.createIntegerConstant(loc, idxTy, i); + auto dimInfo = builder.create( + loc, idxTy, idxTy, idxTy, sourceBox->getAddr(), dimVal); + mlir::Value lb = + fir::factory::readLowerBound(builder, loc, sourceExv, i, one); + mlir::Value extent = dimInfo.getResult(1); + mlir::Value ub = builder.create( + loc, builder.create(loc, extent, lb), one); + mlir::Value dimIndex = builder.createIntegerConstant(loc, i32Ty, i); + genRuntimeSetBounds(builder, loc, box, dimIndex, lb, ub); + } + } + } + + void genSourceAllocation(const Allocation &alloc, + const fir::MutableBoxValue &box) { + // Generate a sequence of runtime calls. + errorManager.genStatCheck(builder, loc); + genAllocateObjectInit(box); + if (alloc.hasCoarraySpec()) + TODO(loc, "coarray allocation"); + if (alloc.type.IsPolymorphic()) + TODO(loc, "polymorphic allocation with SOURCE specifier"); + // Set length of the allocate object if it has. Otherwise, get the length + // from source for the deferred length parameter. + if (lenParams.empty() && box.isCharacter() && + !box.hasNonDeferredLenParams()) + lenParams.push_back(fir::factory::readCharLen(builder, loc, sourceExv)); + genSetDeferredLengthParameters(alloc, box); + genAllocateObjectBounds(alloc, box); + mlir::Value stat = + genRuntimeAllocateSource(builder, loc, box, sourceExv, errorManager); + fir::factory::syncMutableBoxFromIRBox(builder, loc, box); + errorManager.assignStat(builder, loc, stat); } void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) { TODO(loc, "MOLD allocation"); @@ -576,6 +649,8 @@ private: // value of the length parameters that were specified inside. llvm::SmallVector lenParams; ErrorManager errorManager; + // 9.7.1.2(7) The source-expr is evaluated exactly once for each AllocateStmt. + fir::ExtendedValue sourceExv; mlir::Location loc; }; diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp index 9979069..58c245c 100644 --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -7,11 +7,11 @@ //===----------------------------------------------------------------------===// #include "flang/Runtime/allocatable.h" +#include "assign.h" #include "derived.h" #include "stat.h" #include "terminator.h" #include "type-info.h" -#include "flang/Runtime/assign.h" namespace Fortran::runtime { extern "C" { @@ -88,6 +88,22 @@ int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat, return stat; } +int RTNAME(AllocatableAllocateSource)(Descriptor &alloc, + const Descriptor &source, bool hasStat, const Descriptor *errMsg, + const char *sourceFile, int sourceLine) { + if (alloc.Elements() == 0) { + return StatOk; + } + int stat{RTNAME(AllocatableAllocate)( + alloc, hasStat, errMsg, sourceFile, sourceLine)}; + if (stat == StatOk) { + Terminator terminator{sourceFile, sourceLine}; + // 9.7.1.2(7) + Assign(alloc, source, terminator, /*skipRealloc=*/true); + } + return stat; +} + int RTNAME(AllocatableDeallocate)(Descriptor &descriptor, bool hasStat, const Descriptor *errMsg, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; @@ -125,6 +141,6 @@ void RTNAME(AllocatableDeallocateNoFinal)( } } -// TODO: AllocatableCheckLengthParameter, AllocatableAllocateSource +// TODO: AllocatableCheckLengthParameter } } // namespace Fortran::runtime diff --git a/flang/runtime/assign.cpp b/flang/runtime/assign.cpp index 8d79201..63ec732 100644 --- a/flang/runtime/assign.cpp +++ b/flang/runtime/assign.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "flang/Runtime/assign.h" +#include "assign.h" #include "derived.h" #include "stat.h" #include "terminator.h" @@ -59,7 +60,8 @@ static void DoElementalDefinedAssignment(const Descriptor &to, } } -void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator) { +void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator, + bool skipRealloc) { DescriptorAddendum *toAddendum{to.Addendum()}; const typeInfo::DerivedType *toDerived{ toAddendum ? toAddendum->derivedType() : nullptr}; @@ -69,7 +71,7 @@ void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator) { bool wasJustAllocated{false}; if (to.IsAllocatable()) { std::size_t lenParms{fromDerived ? fromDerived->LenParameters() : 0}; - if (to.IsAllocated()) { + if (to.IsAllocated() && !skipRealloc) { // Top-level assignments to allocatable variables (*not* components) // may first deallocate existing content if there's about to be a // change in type or shape; see F'2018 10.2.1.3(3). @@ -196,7 +198,7 @@ void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator) { comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt); comp.CreatePointerDescriptor( fromCompDesc, from, terminator, fromAt); - Assign(toCompDesc, fromCompDesc, terminator); + Assign(toCompDesc, fromCompDesc, terminator, /*skipRealloc=*/false); } } else { // Component has intrinsic type; simply copy raw bytes std::size_t componentByteSize{comp.SizeInBytes(to)}; @@ -241,7 +243,7 @@ void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator) { continue; // F'2018 10.2.1.3(13)(2) } } - Assign(*toDesc, *fromDesc, terminator); + Assign(*toDesc, *fromDesc, terminator, /*skipRealloc=*/false); } break; } diff --git a/flang/runtime/assign.h b/flang/runtime/assign.h new file mode 100644 index 0000000..57dd9f3 --- /dev/null +++ b/flang/runtime/assign.h @@ -0,0 +1,30 @@ +//===-- runtime/assign.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 +// +//===----------------------------------------------------------------------===// + +// Internal APIs for data assignment (both intrinsic assignment and TBP defined +// generic ASSIGNMENT(=)). + +#ifndef FORTRAN_RUNTIME_ASSIGN_INTERNAL_H_ +#define FORTRAN_RUNTIME_ASSIGN_INTERNAL_H_ + +namespace Fortran::runtime { +class Descriptor; +class Terminator; + +// Assigns one object to another via intrinsic assignment (F'2018 10.2.1.3) or +// type-bound (only!) defined assignment (10.2.1.4), as appropriate. Performs +// finalization, scalar expansion, & allocatable (re)allocation as needed. +// Does not perform intrinsic assignment implicit type conversion. Both +// descriptors must be initialized. Recurses as needed to handle components. +// Do not perform allocatable reallocation if \p skipRealloc is true, which is +// used for allocate statement with source specifier. +void Assign( + Descriptor &, const Descriptor &, Terminator &, bool skipRealloc = false); + +} // namespace Fortran::runtime +#endif // FORTRAN_RUNTIME_ASSIGN_INTERNAL_H_ diff --git a/flang/runtime/pointer.cpp b/flang/runtime/pointer.cpp index 408f6ac..c657c0e 100644 --- a/flang/runtime/pointer.cpp +++ b/flang/runtime/pointer.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "flang/Runtime/pointer.h" +#include "assign.h" #include "derived.h" #include "stat.h" #include "terminator.h" @@ -132,6 +133,22 @@ int RTNAME(PointerAllocate)(Descriptor &pointer, bool hasStat, return stat; } +int RTNAME(PointerAllocateSource)(Descriptor &pointer, const Descriptor &source, + bool hasStat, const Descriptor *errMsg, const char *sourceFile, + int sourceLine) { + if (pointer.Elements() == 0) { + return StatOk; + } + int stat{RTNAME(PointerAllocate)( + pointer, hasStat, errMsg, sourceFile, sourceLine)}; + if (stat == StatOk) { + Terminator terminator{sourceFile, sourceLine}; + // 9.7.1.2(7) + Assign(pointer, source, terminator, /*skipRealloc=*/true); + } + return stat; +} + int RTNAME(PointerDeallocate)(Descriptor &pointer, bool hasStat, const Descriptor *errMsg, const char *sourceFile, int sourceLine) { Terminator terminator{sourceFile, sourceLine}; @@ -187,7 +204,7 @@ bool RTNAME(PointerIsAssociatedWith)( return true; } -// TODO: PointerCheckLengthParameter, PointerAllocateSource +// TODO: PointerCheckLengthParameter } // extern "C" } // namespace Fortran::runtime diff --git a/flang/test/Lower/allocate-source-allocatables.f90 b/flang/test/Lower/allocate-source-allocatables.f90 new file mode 100644 index 0000000..f27e660 --- /dev/null +++ b/flang/test/Lower/allocate-source-allocatables.f90 @@ -0,0 +1,369 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test lowering of allocatables for allocate statements with source. + +! CHECK-LABEL: func.func @_QPtest_allocatable_scalar( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QFtest_allocatable_scalarEx1) : !fir.ref>> +! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QFtest_allocatable_scalarEx2) : !fir.ref>> +! CHECK: %[[VAL_3:.*]] = arith.constant false +! CHECK: %[[VAL_4:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_0]] : (!fir.ref) -> !fir.box +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_7]] : (!fir.box) -> !fir.box +! CHECK: %[[VAL_11:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_8]], %[[VAL_9]], %[[VAL_3]], %[[VAL_4]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_7]] : (!fir.box) -> !fir.box +! CHECK: %[[VAL_15:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_12]], %[[VAL_13]], %[[VAL_3]], %[[VAL_4]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: return +! CHECK: } + +subroutine test_allocatable_scalar(a) + real, save, allocatable :: x1, x2 + real :: a + + allocate(x1, x2, source = a) +end + +! CHECK-LABEL: func.func @_QPtest_allocatable_2d_array( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {bindc_name = "sss", uniq_name = "_QFtest_allocatable_2d_arrayEsss"} +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.box>> {bindc_name = "x1", uniq_name = "_QFtest_allocatable_2d_arrayEx1"} +! CHECK: %[[VAL_4:.*]] = fir.alloca !fir.heap> {uniq_name = "_QFtest_allocatable_2d_arrayEx1.addr"} +! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_2d_arrayEx1.lb0"} +! CHECK: %[[VAL_6:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_2d_arrayEx1.ext0"} +! CHECK: %[[VAL_7:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_2d_arrayEx1.lb1"} +! CHECK: %[[VAL_8:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_2d_arrayEx1.ext1"} +! CHECK: %[[VAL_9:.*]] = fir.zero_bits !fir.heap> +! CHECK: fir.store %[[VAL_9]] to %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_10:.*]] = fir.alloca !fir.box>> {bindc_name = "x2", uniq_name = "_QFtest_allocatable_2d_arrayEx2"} +! CHECK: %[[VAL_17:.*]] = fir.alloca !fir.box>> {bindc_name = "x3", uniq_name = "_QFtest_allocatable_2d_arrayEx3"} +! CHECK: %[[VAL_24:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_25:.*]] = fir.convert %[[VAL_24]] : (i32) -> i64 +! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (i64) -> index +! CHECK: %[[VAL_27:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_28:.*]] = arith.cmpi sgt, %[[VAL_26]], %[[VAL_27]] : index +! CHECK: %[[VAL_29:.*]] = arith.select %[[VAL_28]], %[[VAL_26]], %[[VAL_27]] : index +! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (i32) -> i64 +! CHECK: %[[VAL_32:.*]] = fir.convert %[[VAL_31]] : (i64) -> index +! CHECK: %[[VAL_33:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_34:.*]] = arith.cmpi sgt, %[[VAL_32]], %[[VAL_33]] : index +! CHECK: %[[VAL_35:.*]] = arith.select %[[VAL_34]], %[[VAL_32]], %[[VAL_33]] : index +! CHECK: %[[VAL_36:.*]] = arith.constant false +! CHECK: %[[VAL_37:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_40:.*]] = fir.shape %[[VAL_29]], %[[VAL_35]] : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_41:.*]] = fir.embox %[[VAL_1]](%[[VAL_40]]) : (!fir.ref>, !fir.shape<2>) -> !fir.box> +! CHECK: %[[VAL_42:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_43:.*]] = fir.load %[[VAL_6]] : !fir.ref +! CHECK: %[[VAL_44:.*]] = fir.load %[[VAL_7]] : !fir.ref +! CHECK: %[[VAL_45:.*]] = fir.load %[[VAL_8]] : !fir.ref +! CHECK: %[[VAL_46:.*]] = fir.load %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_47:.*]] = fir.shape_shift %[[VAL_42]], %[[VAL_43]], %[[VAL_44]], %[[VAL_45]] : (index, index, index, index) -> !fir.shapeshift<2> +! CHECK: %[[VAL_48:.*]] = fir.embox %[[VAL_46]](%[[VAL_47]]) : (!fir.heap>, !fir.shapeshift<2>) -> !fir.box>> +! CHECK: fir.store %[[VAL_48]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_49:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_50:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_51:.*]]:3 = fir.box_dims %[[VAL_41]], %[[VAL_50]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_52:.*]] = arith.addi %[[VAL_51]]#1, %[[VAL_49]] : index +! CHECK: %[[VAL_53:.*]] = arith.subi %[[VAL_52]], %[[VAL_49]] : index +! CHECK: %[[VAL_54:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_55:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_56:.*]] = fir.convert %[[VAL_49]] : (index) -> i64 +! CHECK: %[[VAL_57:.*]] = fir.convert %[[VAL_53]] : (index) -> i64 +! CHECK: %[[VAL_58:.*]] = fir.call @_FortranAAllocatableSetBounds(%[[VAL_55]], %[[VAL_54]], %[[VAL_56]], %[[VAL_57]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_59:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_60:.*]]:3 = fir.box_dims %[[VAL_41]], %[[VAL_59]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_61:.*]] = arith.addi %[[VAL_60]]#1, %[[VAL_49]] : index +! CHECK: %[[VAL_62:.*]] = arith.subi %[[VAL_61]], %[[VAL_49]] : index +! CHECK: %[[VAL_63:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_64:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_65:.*]] = fir.convert %[[VAL_49]] : (index) -> i64 +! CHECK: %[[VAL_66:.*]] = fir.convert %[[VAL_62]] : (index) -> i64 +! CHECK: %[[VAL_67:.*]] = fir.call @_FortranAAllocatableSetBounds(%[[VAL_64]], %[[VAL_63]], %[[VAL_65]], %[[VAL_66]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_68:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_69:.*]] = fir.convert %[[VAL_41]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_71:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_68]], %[[VAL_69]], %[[VAL_36]], %[[VAL_37]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[VAL_94:.*]] = fir.call @_FortranAAllocatableSetBounds( +! CHECK: %[[VAL_103:.*]] = fir.call @_FortranAAllocatableSetBounds( +! CHECK: %[[VAL_107:.*]] = fir.call @_FortranAAllocatableAllocateSource( +! CHECK: %[[VAL_114:.*]] = arith.constant true +! CHECK: %[[VAL_149:.*]] = fir.call @_FortranAAllocatableSetBounds( +! CHECK: %[[VAL_158:.*]] = fir.call @_FortranAAllocatableSetBounds( +! CHECK: %[[VAL_162:.*]] = fir.call @_FortranAAllocatableAllocateSource(%{{.*}}, %{{.*}}, %[[VAL_114]] + +subroutine test_allocatable_2d_array(n, a) + integer, allocatable :: x1(:,:), x2(:,:), x3(:,:) + integer :: n, sss, a(n, n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(1:3:2, 2:3), stat=sss) +end + +! CHECK-LABEL: func.func @_QPtest_allocatable_with_shapespec( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "a"}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref {fir.bindc_name = "m"}) { +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.box>> {bindc_name = "x1", uniq_name = "_QFtest_allocatable_with_shapespecEx1"} +! CHECK: %[[VAL_4:.*]] = fir.alloca !fir.heap> {uniq_name = "_QFtest_allocatable_with_shapespecEx1.addr"} +! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_with_shapespecEx1.lb0"} +! CHECK: %[[VAL_6:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_with_shapespecEx1.ext0"} +! CHECK: %[[VAL_7:.*]] = fir.zero_bits !fir.heap> +! CHECK: fir.store %[[VAL_7]] to %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_8:.*]] = fir.alloca !fir.box>> {bindc_name = "x2", uniq_name = "_QFtest_allocatable_with_shapespecEx2"} +! CHECK: %[[VAL_9:.*]] = fir.alloca !fir.heap> {uniq_name = "_QFtest_allocatable_with_shapespecEx2.addr"} +! CHECK: %[[VAL_10:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_with_shapespecEx2.lb0"} +! CHECK: %[[VAL_11:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_with_shapespecEx2.ext0"} +! CHECK: %[[VAL_12:.*]] = fir.zero_bits !fir.heap> +! CHECK: fir.store %[[VAL_12]] to %[[VAL_9]] : !fir.ref>> +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (i32) -> i64 +! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i64) -> index +! CHECK: %[[VAL_16:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_17:.*]] = arith.cmpi sgt, %[[VAL_15]], %[[VAL_16]] : index +! CHECK: %[[VAL_18:.*]] = arith.select %[[VAL_17]], %[[VAL_15]], %[[VAL_16]] : index +! CHECK: %[[VAL_19:.*]] = arith.constant false +! CHECK: %[[VAL_20:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_23:.*]] = fir.shape %[[VAL_18]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_24:.*]] = fir.embox %[[VAL_1]](%[[VAL_23]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> +! CHECK: %[[VAL_25:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_6]] : !fir.ref +! CHECK: %[[VAL_27:.*]] = fir.load %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_28:.*]] = fir.shape_shift %[[VAL_25]], %[[VAL_26]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_29:.*]] = fir.embox %[[VAL_27]](%[[VAL_28]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_29]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_30:.*]] = arith.constant 2 : i32 +! CHECK: %[[VAL_31:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_32:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_30]] : (i32) -> i64 +! CHECK: %[[VAL_35:.*]] = fir.convert %[[VAL_31]] : (i32) -> i64 +! CHECK: %[[VAL_36:.*]] = fir.call @_FortranAAllocatableSetBounds(%[[VAL_33]], %[[VAL_32]], %[[VAL_34]], %[[VAL_35]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_24]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_40:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_37]], %[[VAL_38]], %[[VAL_19]], %[[VAL_20]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[VAL_41:.*]] = fir.load %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_42:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_43:.*]]:3 = fir.box_dims %[[VAL_41]], %[[VAL_42]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_44:.*]] = fir.box_addr %[[VAL_41]] : (!fir.box>>) -> !fir.heap> +! CHECK: fir.store %[[VAL_44]] to %[[VAL_4]] : !fir.ref>> +! CHECK: fir.store %[[VAL_43]]#1 to %[[VAL_6]] : !fir.ref +! CHECK: fir.store %[[VAL_43]]#0 to %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_45:.*]] = fir.load %[[VAL_10]] : !fir.ref +! CHECK: %[[VAL_46:.*]] = fir.load %[[VAL_11]] : !fir.ref +! CHECK: %[[VAL_47:.*]] = fir.load %[[VAL_9]] : !fir.ref>> +! CHECK: %[[VAL_48:.*]] = fir.shape_shift %[[VAL_45]], %[[VAL_46]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_49:.*]] = fir.embox %[[VAL_47]](%[[VAL_48]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_49]] to %[[VAL_8]] : !fir.ref>>> +! CHECK: %[[VAL_50:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_51:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_52:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_53:.*]] = fir.convert %[[VAL_8]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_54:.*]] = fir.convert %[[VAL_50]] : (index) -> i64 +! CHECK: %[[VAL_55:.*]] = fir.convert %[[VAL_51]] : (i32) -> i64 +! CHECK: %[[VAL_56:.*]] = fir.call @_FortranAAllocatableSetBounds(%[[VAL_53]], %[[VAL_52]], %[[VAL_54]], %[[VAL_55]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_57:.*]] = fir.convert %[[VAL_8]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_58:.*]] = fir.convert %[[VAL_24]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_60:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_57]], %[[VAL_58]], %[[VAL_19]], %[[VAL_20]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 + +subroutine test_allocatable_with_shapespec(n, a, m) + integer, allocatable :: x1(:), x2(:) + integer :: n, m, a(n) + + allocate(x1(2:m), x2(n), source = a) +end + +! CHECK-LABEL: func.func @_QPtest_allocatable_from_const( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box>> {bindc_name = "x1", uniq_name = "_QFtest_allocatable_from_constEx1"} +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.heap> {uniq_name = "_QFtest_allocatable_from_constEx1.addr"} +! CHECK: %[[VAL_4:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_from_constEx1.lb0"} +! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_from_constEx1.ext0"} +! CHECK: %[[VAL_6:.*]] = fir.zero_bits !fir.heap> +! CHECK: fir.store %[[VAL_6]] to %[[VAL_3]] : !fir.ref>> +! CHECK: %[[VAL_7:.*]] = arith.constant false +! CHECK: %[[VAL_8:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_11:.*]] = arith.constant 5 : index +! CHECK: %[[VAL_13:.*]] = arith.constant 5 : index +! CHECK: %[[VAL_14:.*]] = fir.shape %[[VAL_13]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_15:.*]] = fir.array_load %[[VAL_12:.*]](%[[VAL_14]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<5xi32> +! CHECK: %[[VAL_16:.*]] = fir.allocmem !fir.array<5xi32> +! CHECK: %[[VAL_17:.*]] = fir.shape %[[VAL_11]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_18:.*]] = fir.array_load %[[VAL_16]](%[[VAL_17]]) : (!fir.heap>, !fir.shape<1>) -> !fir.array<5xi32> +! CHECK: %[[VAL_19:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_20:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_21:.*]] = arith.subi %[[VAL_11]], %[[VAL_19]] : index +! CHECK: %[[VAL_27:.*]] = fir.do_loop %[[VAL_23:.*]] = %[[VAL_20]] to %[[VAL_21]] step %[[VAL_19]] unordered iter_args(%[[VAL_24:.*]] = %[[VAL_18]]) -> (!fir.array<5xi32>) { +! CHECK: %[[VAL_25:.*]] = fir.array_fetch %[[VAL_15]], %[[VAL_23]] : (!fir.array<5xi32>, index) -> i32 +! CHECK: %[[VAL_26:.*]] = fir.array_update %[[VAL_24]], %[[VAL_25]], %[[VAL_23]] : (!fir.array<5xi32>, i32, index) -> !fir.array<5xi32> +! CHECK: fir.result %[[VAL_26]] : !fir.array<5xi32> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_18]], %[[VAL_27]] to %[[VAL_16]] : !fir.array<5xi32>, !fir.array<5xi32>, !fir.heap> +! CHECK: %[[VAL_28:.*]] = fir.shape %[[VAL_11]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_29:.*]] = fir.embox %[[VAL_16]](%[[VAL_28]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box> +! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_31:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_32:.*]] = fir.load %[[VAL_3]] : !fir.ref>> +! CHECK: %[[VAL_33:.*]] = fir.shape_shift %[[VAL_30]], %[[VAL_31]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_34:.*]] = fir.embox %[[VAL_32]](%[[VAL_33]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_34]] to %[[VAL_2]] : !fir.ref>>> +! CHECK: %[[VAL_35:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_36:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_37:.*]]:3 = fir.box_dims %[[VAL_29]], %[[VAL_36]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_38:.*]] = arith.addi %[[VAL_37]]#1, %[[VAL_35]] : index +! CHECK: %[[VAL_39:.*]] = arith.subi %[[VAL_38]], %[[VAL_35]] : index +! CHECK: %[[VAL_40:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_41:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_42:.*]] = fir.convert %[[VAL_35]] : (index) -> i64 +! CHECK: %[[VAL_43:.*]] = fir.convert %[[VAL_39]] : (index) -> i64 +! CHECK: %[[VAL_44:.*]] = fir.call @_FortranAAllocatableSetBounds(%[[VAL_41]], %[[VAL_40]], %[[VAL_42]], %[[VAL_43]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_45:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_46:.*]] = fir.convert %[[VAL_29]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_48:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_45]], %[[VAL_46]], %[[VAL_7]], %[[VAL_8]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[VAL_49:.*]] = fir.load %[[VAL_2]] : !fir.ref>>> +! CHECK: %[[VAL_50:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_51:.*]]:3 = fir.box_dims %[[VAL_49]], %[[VAL_50]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_52:.*]] = fir.box_addr %[[VAL_49]] : (!fir.box>>) -> !fir.heap> +! CHECK: fir.store %[[VAL_52]] to %[[VAL_3]] : !fir.ref>> +! CHECK: fir.store %[[VAL_51]]#1 to %[[VAL_5]] : !fir.ref +! CHECK: fir.store %[[VAL_51]]#0 to %[[VAL_4]] : !fir.ref +! CHECK: fir.freemem %[[VAL_16]] : !fir.heap> +! CHECK: return +! CHECK: } + +subroutine test_allocatable_from_const(n, a) + integer, allocatable :: x1(:) + integer :: n, a(n) + + allocate(x1, source = [1, 2, 3, 4, 5]) +end + +! CHECK-LABEL: func.func @_QPtest_allocatable_chararray( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.boxchar<1> {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box>>> {bindc_name = "x1", uniq_name = "_QFtest_allocatable_chararrayEx1"} +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.heap>> {uniq_name = "_QFtest_allocatable_chararrayEx1.addr"} +! CHECK: %[[VAL_4:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_chararrayEx1.lb0"} +! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_chararrayEx1.ext0"} +! CHECK: %[[VAL_6:.*]] = fir.zero_bits !fir.heap>> +! CHECK: fir.store %[[VAL_6]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_7:.*]]:2 = fir.unboxchar %[[VAL_1]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]]#0 : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> i64 +! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (i64) -> index +! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_13:.*]] = arith.cmpi sgt, %[[VAL_11]], %[[VAL_12]] : index +! CHECK: %[[VAL_14:.*]] = arith.select %[[VAL_13]], %[[VAL_11]], %[[VAL_12]] : index +! CHECK: %[[VAL_15:.*]] = arith.constant false +! CHECK: %[[VAL_16:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_19:.*]] = fir.shape %[[VAL_14]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_20:.*]] = fir.embox %[[VAL_8]](%[[VAL_19]]) typeparams %[[VAL_7]]#1 : (!fir.ref>>, !fir.shape<1>, index) -> !fir.box>> +! CHECK: %[[VAL_21:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_22:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_23:.*]] = fir.load %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_24:.*]] = fir.shape_shift %[[VAL_21]], %[[VAL_22]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_25:.*]] = fir.embox %[[VAL_23]](%[[VAL_24]]) : (!fir.heap>>, !fir.shapeshift<1>) -> !fir.box>>> +! CHECK: fir.store %[[VAL_25]] to %[[VAL_2]] : !fir.ref>>>> +! CHECK: %[[VAL_26:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_27:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_28:.*]]:3 = fir.box_dims %[[VAL_20]], %[[VAL_27]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_29:.*]] = arith.addi %[[VAL_28]]#1, %[[VAL_26]] : index +! CHECK: %[[VAL_30:.*]] = arith.subi %[[VAL_29]], %[[VAL_26]] : index +! CHECK: %[[VAL_31:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_32:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_26]] : (index) -> i64 +! CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_30]] : (index) -> i64 +! CHECK: %[[VAL_35:.*]] = fir.call @_FortranAAllocatableSetBounds(%[[VAL_32]], %[[VAL_31]], %[[VAL_33]], %[[VAL_34]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_36:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_20]] : (!fir.box>>) -> !fir.box +! CHECK: %[[VAL_39:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_36]], %[[VAL_37]], %[[VAL_15]], %[[VAL_16]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 + +subroutine test_allocatable_chararray(n, a) + character(4), allocatable :: x1(:) + integer :: n + character(*) :: a(n) + + allocate(x1, source = a) +end + +! CHECK-LABEL: func.func @_QPtest_allocatable_char( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.boxchar<1> {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_2:.*]]:2 = fir.unboxchar %[[VAL_1]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.box>> {bindc_name = "x1", uniq_name = "_QFtest_allocatable_charEx1"} +! CHECK: %[[VAL_4:.*]] = fir.alloca !fir.heap> {uniq_name = "_QFtest_allocatable_charEx1.addr"} +! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_charEx1.len"} +! CHECK: %[[VAL_6:.*]] = fir.zero_bits !fir.heap> +! CHECK: fir.store %[[VAL_6]] to %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_7:.*]] = arith.constant false +! CHECK: %[[VAL_8:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_11:.*]] = fir.embox %[[VAL_2]]#0 typeparams %[[VAL_2]]#1 : (!fir.ref>, index) -> !fir.box> +! CHECK: %[[VAL_12:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_13]] typeparams %[[VAL_12]] : (!fir.heap>, index) -> !fir.box>> +! CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_15:.*]] = fir.box_elesize %[[VAL_11]] : (!fir.box>) -> index +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (index) -> i64 +! CHECK: %[[VAL_18:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_19:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_20:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_21:.*]] = fir.call @_FortranAAllocatableInitCharacter(%[[VAL_16]], %[[VAL_17]], %[[VAL_18]], %[[VAL_19]], %[[VAL_20]]) {{.*}}: (!fir.ref>, i64, i32, i32, i32) -> none +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_11]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_25:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_22]], %[[VAL_23]], %[[VAL_7]], %[[VAL_8]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 + +subroutine test_allocatable_char(n, a) + character(:), allocatable :: x1 + integer :: n + character(*) :: a + + allocate(x1, source = a) +end + +! CHECK-LABEL: func.func @_QPtest_allocatable_derived_type( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>}>>>>> {fir.bindc_name = "y"}) { +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box>>}>>>> {bindc_name = "z", uniq_name = "_QFtest_allocatable_derived_typeEz"} +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.heap>>}>>> {uniq_name = "_QFtest_allocatable_derived_typeEz.addr"} +! CHECK: %[[VAL_3:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_derived_typeEz.lb0"} +! CHECK: %[[VAL_4:.*]] = fir.alloca index {uniq_name = "_QFtest_allocatable_derived_typeEz.ext0"} +! CHECK: %[[VAL_5:.*]] = fir.zero_bits !fir.heap>>}>>> +! CHECK: fir.store %[[VAL_5]] to %[[VAL_2]] : !fir.ref>>}>>>> +! CHECK: %[[VAL_6:.*]] = arith.constant false +! CHECK: %[[VAL_7:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_0]] : !fir.ref>>}>>>>> +! CHECK: %[[VAL_11:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_12:.*]]:3 = fir.box_dims %[[VAL_10]], %[[VAL_11]] : (!fir.box>>}>>>>, index) -> (index, index, index) +! CHECK: %[[VAL_13:.*]] = fir.shift %[[VAL_12]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[VAL_14:.*]] = fir.rebox %[[VAL_10]](%[[VAL_13]]) : (!fir.box>>}>>>>, !fir.shift<1>) -> !fir.box>>}>>> +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_16:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_17:.*]] = fir.load %[[VAL_2]] : !fir.ref>>}>>>> +! CHECK: %[[VAL_18:.*]] = fir.shape_shift %[[VAL_15]], %[[VAL_16]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_19:.*]] = fir.embox %[[VAL_17]](%[[VAL_18]]) : (!fir.heap>>}>>>, !fir.shapeshift<1>) -> !fir.box>>}>>>> +! CHECK: fir.store %[[VAL_19]] to %[[VAL_1]] : !fir.ref>>}>>>>> +! CHECK: %[[VAL_20:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_21:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_22:.*]]:3 = fir.box_dims %[[VAL_14]], %[[VAL_21]] : (!fir.box>>}>>>, index) -> (index, index, index) +! CHECK: %[[VAL_23:.*]] = arith.addi %[[VAL_22]]#1, %[[VAL_12]]#0 : index +! CHECK: %[[VAL_24:.*]] = arith.subi %[[VAL_23]], %[[VAL_20]] : index +! CHECK: %[[VAL_25:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>>}>>>>>) -> !fir.ref> +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_12]]#0 : (index) -> i64 +! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_24]] : (index) -> i64 +! CHECK: %[[VAL_29:.*]] = fir.call @_FortranAAllocatableSetBounds(%[[VAL_26]], %[[VAL_25]], %[[VAL_27]], %[[VAL_28]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_30:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>>}>>>>>) -> !fir.ref> +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_14]] : (!fir.box>>}>>>) -> !fir.box +! CHECK: %[[VAL_33:.*]] = fir.call @_FortranAAllocatableAllocateSource(%[[VAL_30]], %[[VAL_31]], %[[VAL_6]], %[[VAL_7]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 + +subroutine test_allocatable_derived_type(y) + type t + integer, allocatable :: x(:) + end type + type(t), allocatable :: z(:), y(:) + + allocate(z, source=y) +end diff --git a/flang/test/Lower/allocate-source-pointers.f90 b/flang/test/Lower/allocate-source-pointers.f90 new file mode 100644 index 0000000..aaf5201 --- /dev/null +++ b/flang/test/Lower/allocate-source-pointers.f90 @@ -0,0 +1,356 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test lowering of pointers for allocate statements with source. + +! CHECK-LABEL: func.func @_QPtest_pointer_scalar( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_1:.*]] = fir.address_of(@_QFtest_pointer_scalarEx1) : !fir.ref>> +! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QFtest_pointer_scalarEx2) : !fir.ref>> +! CHECK: %[[VAL_3:.*]] = arith.constant false +! CHECK: %[[VAL_4:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_0]] : (!fir.ref) -> !fir.box +! CHECK: %[[VAL_8:.*]] = fir.zero_bits !fir.ptr +! CHECK: %[[VAL_9:.*]] = fir.embox %[[VAL_8]] : (!fir.ptr) -> !fir.box> +! CHECK: fir.store %[[VAL_9]] to %[[VAL_1]] : !fir.ref>> +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_7]] : (!fir.box) -> !fir.box +! CHECK: %[[VAL_13:.*]] = fir.call @_FortranAPointerAllocateSource(%[[VAL_10]], %[[VAL_11]], %[[VAL_3]], %[[VAL_4]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 + +subroutine test_pointer_scalar(a) + real, save, pointer :: x1, x2 + real :: a + + allocate(x1, x2, source = a) +end + +! CHECK-LABEL: func.func @_QPtest_pointer_2d_array( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca i32 {bindc_name = "sss", uniq_name = "_QFtest_pointer_2d_arrayEsss"} +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.box>> {bindc_name = "x1", uniq_name = "_QFtest_pointer_2d_arrayEx1"} +! CHECK: %[[VAL_4:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_6:.*]] = fir.shape %[[VAL_5]], %[[VAL_5]] : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_4]](%[[VAL_6]]) : (!fir.ptr>, !fir.shape<2>) -> !fir.box>> +! CHECK: fir.store %[[VAL_7]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_8:.*]] = fir.alloca !fir.box>> {bindc_name = "x2", uniq_name = "_QFtest_pointer_2d_arrayEx2"} +! CHECK: %[[VAL_13:.*]] = fir.alloca !fir.box>> {bindc_name = "x3", uniq_name = "_QFtest_pointer_2d_arrayEx3"} +! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> i64 +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i64) -> index +! CHECK: %[[VAL_21:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_22:.*]] = arith.cmpi sgt, %[[VAL_20]], %[[VAL_21]] : index +! CHECK: %[[VAL_23:.*]] = arith.select %[[VAL_22]], %[[VAL_20]], %[[VAL_21]] : index +! CHECK: %[[VAL_24:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_25:.*]] = fir.convert %[[VAL_24]] : (i32) -> i64 +! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (i64) -> index +! CHECK: %[[VAL_27:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_28:.*]] = arith.cmpi sgt, %[[VAL_26]], %[[VAL_27]] : index +! CHECK: %[[VAL_29:.*]] = arith.select %[[VAL_28]], %[[VAL_26]], %[[VAL_27]] : index +! CHECK: %[[VAL_30:.*]] = arith.constant false +! CHECK: %[[VAL_31:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_34:.*]] = fir.shape %[[VAL_23]], %[[VAL_29]] : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_35:.*]] = fir.embox %[[VAL_1]](%[[VAL_34]]) : (!fir.ref>, !fir.shape<2>) -> !fir.box> +! CHECK: %[[VAL_36:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_37:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_38:.*]] = fir.shape %[[VAL_37]], %[[VAL_37]] : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_39:.*]] = fir.embox %[[VAL_36]](%[[VAL_38]]) : (!fir.ptr>, !fir.shape<2>) -> !fir.box>> +! CHECK: fir.store %[[VAL_39]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_40:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_41:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_42:.*]]:3 = fir.box_dims %[[VAL_35]], %[[VAL_41]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_43:.*]] = arith.addi %[[VAL_42]]#1, %[[VAL_40]] : index +! CHECK: %[[VAL_44:.*]] = arith.subi %[[VAL_43]], %[[VAL_40]] : index +! CHECK: %[[VAL_45:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_46:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_47:.*]] = fir.convert %[[VAL_40]] : (index) -> i64 +! CHECK: %[[VAL_48:.*]] = fir.convert %[[VAL_44]] : (index) -> i64 +! CHECK: %[[VAL_49:.*]] = fir.call @_FortranAPointerSetBounds(%[[VAL_46]], %[[VAL_45]], %[[VAL_47]], %[[VAL_48]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_50:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_51:.*]]:3 = fir.box_dims %[[VAL_35]], %[[VAL_50]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_52:.*]] = arith.addi %[[VAL_51]]#1, %[[VAL_40]] : index +! CHECK: %[[VAL_53:.*]] = arith.subi %[[VAL_52]], %[[VAL_40]] : index +! CHECK: %[[VAL_54:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_55:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_56:.*]] = fir.convert %[[VAL_40]] : (index) -> i64 +! CHECK: %[[VAL_57:.*]] = fir.convert %[[VAL_53]] : (index) -> i64 +! CHECK: %[[VAL_58:.*]] = fir.call @_FortranAPointerSetBounds(%[[VAL_55]], %[[VAL_54]], %[[VAL_56]], %[[VAL_57]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_59:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_60:.*]] = fir.convert %[[VAL_35]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_62:.*]] = fir.call @_FortranAPointerAllocateSource(%[[VAL_59]], %[[VAL_60]], %[[VAL_30]], %[[VAL_31]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[VAL_76:.*]] = fir.call @_FortranAPointerSetBounds( +! CHECK: %[[VAL_85:.*]] = fir.call @_FortranAPointerSetBounds( +! CHECK: %[[VAL_89:.*]] = fir.call @_FortranAPointerAllocateSource( +! CHECK: %[[VAL_90:.*]] = arith.constant true +! CHECK: %[[VAL_122:.*]] = fir.call @_FortranAPointerSetBounds( +! CHECK: %[[VAL_131:.*]] = fir.call @_FortranAPointerSetBounds( +! CHECK: %[[VAL_135:.*]] = fir.call @_FortranAPointerAllocateSource(%{{.*}}, %{{.*}}, %[[VAL_90]] + +subroutine test_pointer_2d_array(n, a) + integer, pointer :: x1(:,:), x2(:,:), x3(:,:) + integer :: n, sss, a(n, n) + + allocate(x1, x2, source = a) + allocate(x3, source = a(1:3:2, 2:3), stat=sss) +end + +! CHECK-LABEL: func.func @_QPtest_pointer_with_shapespec( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "a"}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref {fir.bindc_name = "m"}) { +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.box>> {bindc_name = "x1", uniq_name = "_QFtest_pointer_with_shapespecEx1"} +! CHECK: %[[VAL_4:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_6:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_4]](%[[VAL_6]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_7]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_8:.*]] = fir.alloca !fir.box>> {bindc_name = "x2", uniq_name = "_QFtest_pointer_with_shapespecEx2"} +! CHECK: %[[VAL_9:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_11:.*]] = fir.shape %[[VAL_10]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_9]](%[[VAL_11]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_12]] to %[[VAL_8]] : !fir.ref>>> +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (i32) -> i64 +! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i64) -> index +! CHECK: %[[VAL_16:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_17:.*]] = arith.cmpi sgt, %[[VAL_15]], %[[VAL_16]] : index +! CHECK: %[[VAL_18:.*]] = arith.select %[[VAL_17]], %[[VAL_15]], %[[VAL_16]] : index +! CHECK: %[[VAL_19:.*]] = arith.constant false +! CHECK: %[[VAL_20:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_23:.*]] = fir.shape %[[VAL_18]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_24:.*]] = fir.embox %[[VAL_1]](%[[VAL_23]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> +! CHECK: %[[VAL_25:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_26:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_27:.*]] = fir.shape %[[VAL_26]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_28:.*]] = fir.embox %[[VAL_25]](%[[VAL_27]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_28]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_29:.*]] = arith.constant 2 : i32 +! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_31:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_32:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_29]] : (i32) -> i64 +! CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_30]] : (i32) -> i64 +! CHECK: %[[VAL_35:.*]] = fir.call @_FortranAPointerSetBounds(%[[VAL_32]], %[[VAL_31]], %[[VAL_33]], %[[VAL_34]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_36:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_24]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_39:.*]] = fir.call @_FortranAPointerAllocateSource(%[[VAL_36]], %[[VAL_37]], %[[VAL_19]], %[[VAL_20]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[VAL_40:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_41:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_42:.*]] = fir.shape %[[VAL_41]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_43:.*]] = fir.embox %[[VAL_40]](%[[VAL_42]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_43]] to %[[VAL_8]] : !fir.ref>>> +! CHECK: %[[VAL_44:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_45:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_46:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_47:.*]] = fir.convert %[[VAL_8]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_48:.*]] = fir.convert %[[VAL_44]] : (index) -> i64 +! CHECK: %[[VAL_49:.*]] = fir.convert %[[VAL_45]] : (i32) -> i64 +! CHECK: %[[VAL_50:.*]] = fir.call @_FortranAPointerSetBounds(%[[VAL_47]], %[[VAL_46]], %[[VAL_48]], %[[VAL_49]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_51:.*]] = fir.convert %[[VAL_8]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_52:.*]] = fir.convert %[[VAL_24]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_54:.*]] = fir.call @_FortranAPointerAllocateSource(%[[VAL_51]], %[[VAL_52]], %[[VAL_19]], %[[VAL_20]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: return +! CHECK: } + +subroutine test_pointer_with_shapespec(n, a, m) + integer, pointer :: x1(:), x2(:) + integer :: n, m, a(n) + + allocate(x1(2:m), x2(n), source = a) +end + +! CHECK-LABEL: func.func @_QPtest_pointer_from_const( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref> {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box>> {bindc_name = "x1", uniq_name = "_QFtest_pointer_from_constEx1"} +! CHECK: %[[VAL_3:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_3]](%[[VAL_5]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_6]] to %[[VAL_2]] : !fir.ref>>> +! CHECK: %[[VAL_7:.*]] = arith.constant false +! CHECK: %[[VAL_8:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_11:.*]] = arith.constant 5 : index +! CHECK: %[[VAL_13:.*]] = arith.constant 5 : index +! CHECK: %[[VAL_14:.*]] = fir.shape %[[VAL_13]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_15:.*]] = fir.array_load %[[VAL_12:.*]](%[[VAL_14]]) : (!fir.ref>, !fir.shape<1>) -> !fir.array<5xi32> +! CHECK: %[[VAL_16:.*]] = fir.allocmem !fir.array<5xi32> +! CHECK: %[[VAL_17:.*]] = fir.shape %[[VAL_11]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_18:.*]] = fir.array_load %[[VAL_16]](%[[VAL_17]]) : (!fir.heap>, !fir.shape<1>) -> !fir.array<5xi32> +! CHECK: %[[VAL_19:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_20:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_21:.*]] = arith.subi %[[VAL_11]], %[[VAL_19]] : index +! CHECK: %[[VAL_22:.*]] = fir.do_loop %[[VAL_23:.*]] = %[[VAL_20]] to %[[VAL_21]] step %[[VAL_19]] unordered iter_args(%[[VAL_24:.*]] = %[[VAL_18]]) -> (!fir.array<5xi32>) { +! CHECK: %[[VAL_25:.*]] = fir.array_fetch %[[VAL_15]], %[[VAL_23]] : (!fir.array<5xi32>, index) -> i32 +! CHECK: %[[VAL_26:.*]] = fir.array_update %[[VAL_24]], %[[VAL_25]], %[[VAL_23]] : (!fir.array<5xi32>, i32, index) -> !fir.array<5xi32> +! CHECK: fir.result %[[VAL_26]] : !fir.array<5xi32> +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_18]], %[[VAL_27:.*]] to %[[VAL_16]] : !fir.array<5xi32>, !fir.array<5xi32>, !fir.heap> +! CHECK: %[[VAL_28:.*]] = fir.shape %[[VAL_11]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_29:.*]] = fir.embox %[[VAL_16]](%[[VAL_28]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box> +! CHECK: %[[VAL_30:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_31:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_32:.*]] = fir.shape %[[VAL_31]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_33:.*]] = fir.embox %[[VAL_30]](%[[VAL_32]]) : (!fir.ptr>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[VAL_33]] to %[[VAL_2]] : !fir.ref>>> +! CHECK: %[[VAL_34:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_35:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_36:.*]]:3 = fir.box_dims %[[VAL_29]], %[[VAL_35]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_37:.*]] = arith.addi %[[VAL_36]]#1, %[[VAL_34]] : index +! CHECK: %[[VAL_38:.*]] = arith.subi %[[VAL_37]], %[[VAL_34]] : index +! CHECK: %[[VAL_39:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_40:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_41:.*]] = fir.convert %[[VAL_34]] : (index) -> i64 +! CHECK: %[[VAL_42:.*]] = fir.convert %[[VAL_38]] : (index) -> i64 +! CHECK: %[[VAL_43:.*]] = fir.call @_FortranAPointerSetBounds(%[[VAL_40]], %[[VAL_39]], %[[VAL_41]], %[[VAL_42]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_44:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_45:.*]] = fir.convert %[[VAL_29]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_47:.*]] = fir.call @_FortranAPointerAllocateSource(%[[VAL_44]], %[[VAL_45]], %[[VAL_7]], %[[VAL_8]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: fir.freemem %[[VAL_16]] : !fir.heap> +! CHECK: return +! CHECK: } + +subroutine test_pointer_from_const(n, a) + integer, pointer :: x1(:) + integer :: n, a(n) + + allocate(x1, source = [1, 2, 3, 4, 5]) +end + +! CHECK-LABEL: func.func @_QPtest_pointer_chararray( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.boxchar<1> {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box>>> {bindc_name = "x1", uniq_name = "_QFtest_pointer_chararrayEx1"} +! CHECK: %[[VAL_3:.*]] = fir.zero_bits !fir.ptr>> +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_3]](%[[VAL_5]]) : (!fir.ptr>>, !fir.shape<1>) -> !fir.box>>> +! CHECK: fir.store %[[VAL_6]] to %[[VAL_2]] : !fir.ref>>>> +! CHECK: %[[VAL_7:.*]]:2 = fir.unboxchar %[[VAL_1]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]]#0 : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_0]] : !fir.ref +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> i64 +! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (i64) -> index +! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_13:.*]] = arith.cmpi sgt, %[[VAL_11]], %[[VAL_12]] : index +! CHECK: %[[VAL_14:.*]] = arith.select %[[VAL_13]], %[[VAL_11]], %[[VAL_12]] : index +! CHECK: %[[VAL_15:.*]] = arith.constant false +! CHECK: %[[VAL_16:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_19:.*]] = fir.shape %[[VAL_14]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_20:.*]] = fir.embox %[[VAL_8]](%[[VAL_19]]) typeparams %[[VAL_7]]#1 : (!fir.ref>>, !fir.shape<1>, index) -> !fir.box>> +! CHECK: %[[VAL_21:.*]] = fir.zero_bits !fir.ptr>> +! CHECK: %[[VAL_22:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_23:.*]] = fir.shape %[[VAL_22]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_24:.*]] = fir.embox %[[VAL_21]](%[[VAL_23]]) : (!fir.ptr>>, !fir.shape<1>) -> !fir.box>>> +! CHECK: fir.store %[[VAL_24]] to %[[VAL_2]] : !fir.ref>>>> +! CHECK: %[[VAL_25:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_26:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_27:.*]]:3 = fir.box_dims %[[VAL_20]], %[[VAL_26]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_28:.*]] = arith.addi %[[VAL_27]]#1, %[[VAL_25]] : index +! CHECK: %[[VAL_29:.*]] = arith.subi %[[VAL_28]], %[[VAL_25]] : index +! CHECK: %[[VAL_30:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[VAL_32:.*]] = fir.convert %[[VAL_25]] : (index) -> i64 +! CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_29]] : (index) -> i64 +! CHECK: %[[VAL_34:.*]] = fir.call @_FortranAPointerSetBounds(%[[VAL_31]], %[[VAL_30]], %[[VAL_32]], %[[VAL_33]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_35:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[VAL_36:.*]] = fir.convert %[[VAL_20]] : (!fir.box>>) -> !fir.box +! CHECK: %[[VAL_38:.*]] = fir.call @_FortranAPointerAllocateSource(%[[VAL_35]], %[[VAL_36]], %[[VAL_15]], %[[VAL_16]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: return +! CHECK: } + +subroutine test_pointer_chararray(n, a) + character(4), pointer :: x1(:) + integer :: n + character(*) :: a(n) + + allocate(x1, source = a) +end + +! CHECK-LABEL: func.func @_QPtest_pointer_char( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref {fir.bindc_name = "n"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.boxchar<1> {fir.bindc_name = "a"}) { +! CHECK: %[[VAL_2:.*]]:2 = fir.unboxchar %[[VAL_1]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_3:.*]] = fir.alloca !fir.box>> {bindc_name = "x1", uniq_name = "_QFtest_pointer_charEx1"} +! CHECK: %[[VAL_4:.*]] = fir.alloca !fir.ptr> {uniq_name = "_QFtest_pointer_charEx1.addr"} +! CHECK: %[[VAL_5:.*]] = fir.alloca index {uniq_name = "_QFtest_pointer_charEx1.len"} +! CHECK: %[[VAL_6:.*]] = fir.zero_bits !fir.ptr> +! CHECK: fir.store %[[VAL_6]] to %[[VAL_4]] : !fir.ref>> +! CHECK: %[[VAL_7:.*]] = arith.constant false +! CHECK: %[[VAL_8:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_11:.*]] = fir.embox %[[VAL_2]]#0 typeparams %[[VAL_2]]#1 : (!fir.ref>, index) -> !fir.box> +! CHECK: %[[VAL_12:.*]] = fir.zero_bits !fir.ptr> +! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_12]] typeparams %[[VAL_13]] : (!fir.ptr>, index) -> !fir.box>> +! CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_15:.*]] = fir.box_elesize %[[VAL_11]] : (!fir.box>) -> index +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_15]] : (index) -> i64 +! CHECK: %[[VAL_18:.*]] = arith.constant 1 : i32 +! CHECK: %[[VAL_19:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_20:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_21:.*]] = fir.call @_FortranAPointerNullifyCharacter(%[[VAL_16]], %[[VAL_17]], %[[VAL_18]], %[[VAL_19]], %[[VAL_20]]) {{.*}}: (!fir.ref>, i64, i32, i32, i32) -> none +! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_3]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_11]] : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_25:.*]] = fir.call @_FortranAPointerAllocateSource(%[[VAL_22]], %[[VAL_23]], %[[VAL_7]], %[[VAL_8]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_3]] : !fir.ref>>> +! CHECK: %[[VAL_27:.*]] = fir.box_elesize %[[VAL_26]] : (!fir.box>>) -> index +! CHECK: %[[VAL_28:.*]] = fir.box_addr %[[VAL_26]] : (!fir.box>>) -> !fir.ptr> +! CHECK: fir.store %[[VAL_28]] to %[[VAL_4]] : !fir.ref>> +! CHECK: fir.store %[[VAL_27]] to %[[VAL_5]] : !fir.ref +! CHECK: return +! CHECK: } + +subroutine test_pointer_char(n, a) + character(:), pointer :: x1 + integer :: n + character(*) :: a + + allocate(x1, source = a) +end + +! CHECK-LABEL: func.func @_QPtest_pointer_derived_type( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>}>>>>> {fir.bindc_name = "y"}) { +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box>>}>>>> {bindc_name = "z", uniq_name = "_QFtest_pointer_derived_typeEz"} +! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.ptr>>}>>> +! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_2]](%[[VAL_4]]) : (!fir.ptr>>}>>>, !fir.shape<1>) -> !fir.box>>}>>>> +! CHECK: fir.store %[[VAL_5]] to %[[VAL_1]] : !fir.ref>>}>>>>> +! CHECK: %[[VAL_6:.*]] = arith.constant false +! CHECK: %[[VAL_7:.*]] = fir.absent !fir.box +! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_0]] : !fir.ref>>}>>>>> +! CHECK: %[[VAL_11:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_12:.*]]:3 = fir.box_dims %[[VAL_10]], %[[VAL_11]] : (!fir.box>>}>>>>, index) -> (index, index, index) +! CHECK: %[[VAL_13:.*]] = fir.shift %[[VAL_12]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[VAL_14:.*]] = fir.rebox %[[VAL_10]](%[[VAL_13]]) : (!fir.box>>}>>>>, !fir.shift<1>) -> !fir.box>>}>>> +! CHECK: %[[VAL_15:.*]] = fir.zero_bits !fir.ptr>>}>>> +! CHECK: %[[VAL_16:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_17:.*]] = fir.shape %[[VAL_16]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_18:.*]] = fir.embox %[[VAL_15]](%[[VAL_17]]) : (!fir.ptr>>}>>>, !fir.shape<1>) -> !fir.box>>}>>>> +! CHECK: fir.store %[[VAL_18]] to %[[VAL_1]] : !fir.ref>>}>>>>> +! CHECK: %[[VAL_19:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_20:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_21:.*]]:3 = fir.box_dims %[[VAL_14]], %[[VAL_20]] : (!fir.box>>}>>>, index) -> (index, index, index) +! CHECK: %[[VAL_22:.*]] = arith.addi %[[VAL_21]]#1, %[[VAL_12]]#0 : index +! CHECK: %[[VAL_23:.*]] = arith.subi %[[VAL_22]], %[[VAL_19]] : index +! CHECK: %[[VAL_24:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_25:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>>}>>>>>) -> !fir.ref> +! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_12]]#0 : (index) -> i64 +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_23]] : (index) -> i64 +! CHECK: %[[VAL_28:.*]] = fir.call @_FortranAPointerSetBounds(%[[VAL_25]], %[[VAL_24]], %[[VAL_26]], %[[VAL_27]]) {{.*}}: (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_1]] : (!fir.ref>>}>>>>>) -> !fir.ref> +! CHECK: %[[VAL_30:.*]] = fir.convert %[[VAL_14]] : (!fir.box>>}>>>) -> !fir.box +! CHECK: %[[VAL_32:.*]] = fir.call @_FortranAPointerAllocateSource(%[[VAL_29]], %[[VAL_30]], %[[VAL_6]], %[[VAL_7]], %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: return +! CHECK: } + +subroutine test_pointer_derived_type(y) + type t + integer, pointer :: x(:) + end type + type(t), pointer :: z(:), y(:) + + allocate(z, source=y) +end -- 2.7.4