Index: flang/include/flang/Runtime/assign.h =================================================================== --- flang/include/flang/Runtime/assign.h +++ 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 Index: flang/lib/Lower/Allocatable.cpp =================================================================== --- flang/lib/Lower/Allocatable.cpp +++ flang/lib/Lower/Allocatable.cpp @@ -183,6 +183,29 @@ 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, @@ -240,8 +263,11 @@ 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)) @@ -378,45 +404,13 @@ } // 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); @@ -463,8 +457,87 @@ 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"); @@ -539,6 +612,8 @@ // 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; }; Index: flang/runtime/CMakeLists.txt =================================================================== --- flang/runtime/CMakeLists.txt +++ flang/runtime/CMakeLists.txt @@ -74,6 +74,7 @@ ISO_Fortran_binding.cpp allocatable.cpp assign.cpp + assign-object.cpp buffer.cpp command.cpp complex-powi.cpp Index: flang/runtime/allocatable.cpp =================================================================== --- flang/runtime/allocatable.cpp +++ flang/runtime/allocatable.cpp @@ -7,11 +7,11 @@ //===----------------------------------------------------------------------===// #include "flang/Runtime/allocatable.h" +#include "assign-object.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 @@ 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}; @@ -112,6 +128,6 @@ } } -// TODO: AllocatableCheckLengthParameter, AllocatableAllocateSource +// TODO: AllocatableCheckLengthParameter } } // namespace Fortran::runtime Index: flang/runtime/assign-object.h =================================================================== --- /dev/null +++ flang/runtime/assign-object.h @@ -0,0 +1,30 @@ +//===-- runtime/assign-object.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_OBJECT_H_ +#define FORTRAN_RUNTIME_ASSIGN_OBJECT_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_OBJECT_H_ Index: flang/runtime/assign-object.cpp =================================================================== --- /dev/null +++ flang/runtime/assign-object.cpp @@ -0,0 +1,278 @@ +//===-- runtime/assign-object.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 "assign-object.h" +#include "derived.h" +#include "stat.h" +#include "terminator.h" +#include "type-info.h" +#include "flang/Runtime/descriptor.h" + +namespace Fortran::runtime { + +static void DoScalarDefinedAssignment(const Descriptor &to, + const Descriptor &from, const typeInfo::SpecialBinding &special) { + bool toIsDesc{special.IsArgDescriptor(0)}; + bool fromIsDesc{special.IsArgDescriptor(1)}; + if (toIsDesc) { + if (fromIsDesc) { + auto *p{ + special.GetProc()}; + p(to, from); + } else { + auto *p{special.GetProc()}; + p(to, from.raw().base_addr); + } + } else { + if (fromIsDesc) { + auto *p{special.GetProc()}; + p(to.raw().base_addr, from); + } else { + auto *p{special.GetProc()}; + p(to.raw().base_addr, from.raw().base_addr); + } + } +} + +static void DoElementalDefinedAssignment(const Descriptor &to, + const Descriptor &from, const typeInfo::SpecialBinding &special, + std::size_t toElements, SubscriptValue toAt[], SubscriptValue fromAt[]) { + StaticDescriptor statDesc[2]; + Descriptor &toElementDesc{statDesc[0].descriptor()}; + Descriptor &fromElementDesc{statDesc[1].descriptor()}; + toElementDesc = to; + toElementDesc.raw().attribute = CFI_attribute_pointer; + toElementDesc.raw().rank = 0; + fromElementDesc = from; + fromElementDesc.raw().attribute = CFI_attribute_pointer; + fromElementDesc.raw().rank = 0; + for (std::size_t j{0}; j < toElements; + ++j, to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + toElementDesc.set_base_addr(to.Element(toAt)); + fromElementDesc.set_base_addr(from.Element(fromAt)); + DoScalarDefinedAssignment(toElementDesc, fromElementDesc, special); + } +} + +void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator, + bool skipRealloc) { + DescriptorAddendum *toAddendum{to.Addendum()}; + const typeInfo::DerivedType *toDerived{ + toAddendum ? toAddendum->derivedType() : nullptr}; + const DescriptorAddendum *fromAddendum{from.Addendum()}; + const typeInfo::DerivedType *fromDerived{ + fromAddendum ? fromAddendum->derivedType() : nullptr}; + bool wasJustAllocated{false}; + if (to.IsAllocatable()) { + std::size_t lenParms{fromDerived ? fromDerived->LenParameters() : 0}; + 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). + bool deallocate{false}; + if (to.type() != from.type()) { + deallocate = true; + } else if (toDerived != fromDerived) { + deallocate = true; + } else { + if (toAddendum) { + // Distinct LEN parameters? Deallocate + for (std::size_t j{0}; j < lenParms; ++j) { + if (toAddendum->LenParameterValue(j) != + fromAddendum->LenParameterValue(j)) { + deallocate = true; + break; + } + } + } + if (from.rank() > 0) { + // Distinct shape? Deallocate + int rank{to.rank()}; + for (int j{0}; j < rank; ++j) { + if (to.GetDimension(j).Extent() != from.GetDimension(j).Extent()) { + deallocate = true; + break; + } + } + } + } + if (deallocate) { + to.Destroy(true /*finalize*/); + } + } else if (to.rank() != from.rank()) { + terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to " + "unallocated allocatable", + to.rank(), from.rank()); + } + if (!to.IsAllocated()) { + to.raw().type = from.raw().type; + to.raw().elem_len = from.ElementBytes(); + if (toAddendum) { + toDerived = fromDerived; + toAddendum->set_derivedType(toDerived); + for (std::size_t j{0}; j < lenParms; ++j) { + toAddendum->SetLenParameterValue( + j, fromAddendum->LenParameterValue(j)); + } + } + // subtle: leave bounds in place when "from" is scalar (10.2.1.3(3)) + int rank{from.rank()}; + auto stride{static_cast(to.ElementBytes())}; + for (int j{0}; j < rank; ++j) { + auto &toDim{to.GetDimension(j)}; + const auto &fromDim{from.GetDimension(j)}; + toDim.SetBounds(fromDim.LowerBound(), fromDim.UpperBound()); + toDim.SetByteStride(stride); + stride *= toDim.Extent(); + } + ReturnError(terminator, to.Allocate()); + if (fromDerived && !fromDerived->noInitializationNeeded()) { + ReturnError(terminator, Initialize(to, *toDerived, terminator)); + } + wasJustAllocated = true; + } + } + SubscriptValue toAt[maxRank]; + to.GetLowerBounds(toAt); + // Scalar expansion of the RHS is implied by using the same empty + // subscript values on each (seemingly) elemental reference into + // "from". + SubscriptValue fromAt[maxRank]; + from.GetLowerBounds(fromAt); + std::size_t toElements{to.Elements()}; + if (from.rank() > 0 && toElements != from.Elements()) { + terminator.Crash("Assign: mismatching element counts in array assignment " + "(to %zd, from %zd)", + toElements, from.Elements()); + } + if (to.type() != from.type()) { + terminator.Crash("Assign: mismatching types (to code %d != from code %d)", + to.type().raw(), from.type().raw()); + } + std::size_t elementBytes{to.ElementBytes()}; + if (elementBytes != from.ElementBytes()) { + terminator.Crash( + "Assign: mismatching element sizes (to %zd bytes != from %zd bytes)", + elementBytes, from.ElementBytes()); + } + if (toDerived) { // Derived type assignment + // Check for defined assignment type-bound procedures (10.2.1.4-5) + if (to.rank() == 0) { + if (const auto *special{toDerived->FindSpecialBinding( + typeInfo::SpecialBinding::Which::ScalarAssignment)}) { + return DoScalarDefinedAssignment(to, from, *special); + } + } + if (const auto *special{toDerived->FindSpecialBinding( + typeInfo::SpecialBinding::Which::ElementalAssignment)}) { + return DoElementalDefinedAssignment( + to, from, *special, toElements, toAt, fromAt); + } + // Derived type intrinsic assignment, which is componentwise and elementwise + // for all components, including parent components (10.2.1.2-3). + // The target is first finalized if still necessary (7.5.6.3(1)) + if (!wasJustAllocated && !toDerived->noFinalizationNeeded()) { + Finalize(to, *toDerived); + } + // Copy the data components (incl. the parent) first. + const Descriptor &componentDesc{toDerived->component()}; + std::size_t numComponents{componentDesc.Elements()}; + for (std::size_t k{0}; k < numComponents; ++k) { + const auto &comp{ + *componentDesc.ZeroBasedIndexedElement( + k)}; // TODO: exploit contiguity here + switch (comp.genre()) { + case typeInfo::Component::Genre::Data: + if (comp.category() == TypeCategory::Derived) { + StaticDescriptor statDesc[2]; + Descriptor &toCompDesc{statDesc[0].descriptor()}; + Descriptor &fromCompDesc{statDesc[1].descriptor()}; + for (std::size_t j{0}; j < toElements; ++j, + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt); + comp.CreatePointerDescriptor( + fromCompDesc, from, terminator, fromAt); + Assign(toCompDesc, fromCompDesc, terminator, /*skipRealloc=*/false); + } + } else { // Component has intrinsic type; simply copy raw bytes + std::size_t componentByteSize{comp.SizeInBytes(to)}; + for (std::size_t j{0}; j < toElements; ++j, + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + std::memmove(to.Element(toAt) + comp.offset(), + from.Element(fromAt) + comp.offset(), + componentByteSize); + } + } + break; + case typeInfo::Component::Genre::Pointer: { + std::size_t componentByteSize{comp.SizeInBytes(to)}; + for (std::size_t j{0}; j < toElements; ++j, + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + std::memmove(to.Element(toAt) + comp.offset(), + from.Element(fromAt) + comp.offset(), + componentByteSize); + } + } break; + case typeInfo::Component::Genre::Allocatable: + case typeInfo::Component::Genre::Automatic: + for (std::size_t j{0}; j < toElements; ++j, + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + auto *toDesc{reinterpret_cast( + to.Element(toAt) + comp.offset())}; + const auto *fromDesc{reinterpret_cast( + from.Element(fromAt) + comp.offset())}; + if (toDesc->IsAllocatable()) { + if (toDesc->IsAllocated()) { + // Allocatable components of the LHS are unconditionally + // deallocated before assignment (F'2018 10.2.1.3(13)(1)), + // unlike a "top-level" assignment to a variable, where + // deallocation is optional. + // TODO: Consider skipping this step and deferring the + // deallocation to the recursive activation of Assign(), + // which might be able to avoid deallocation/reallocation + // when the existing allocation can be reoccupied. + toDesc->Destroy(false /*already finalized*/); + } + if (!fromDesc->IsAllocated()) { + continue; // F'2018 10.2.1.3(13)(2) + } + } + Assign(*toDesc, *fromDesc, terminator, /*skipRealloc=*/false); + } + break; + } + } + // Copy procedure pointer components + const Descriptor &procPtrDesc{toDerived->procPtr()}; + std::size_t numProcPtrs{procPtrDesc.Elements()}; + for (std::size_t k{0}; k < numProcPtrs; ++k) { + const auto &procPtr{ + *procPtrDesc.ZeroBasedIndexedElement(k)}; + for (std::size_t j{0}; j < toElements; ++j, to.IncrementSubscripts(toAt), + from.IncrementSubscripts(fromAt)) { + std::memmove(to.Element(toAt) + procPtr.offset, + from.Element(fromAt) + procPtr.offset, + sizeof(typeInfo::ProcedurePointer)); + } + } + } else { // intrinsic type, intrinsic assignment + if (to.rank() == from.rank() && to.IsContiguous() && from.IsContiguous()) { + // Everything is contiguous; do a single big copy + std::memmove( + to.raw().base_addr, from.raw().base_addr, toElements * elementBytes); + } else { // elemental copies + for (std::size_t n{toElements}; n-- > 0; + to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { + std::memmove(to.Element(toAt), from.Element(fromAt), + elementBytes); + } + } + } +} + +} // namespace Fortran::runtime Index: flang/runtime/assign.cpp =================================================================== --- flang/runtime/assign.cpp +++ flang/runtime/assign.cpp @@ -7,273 +7,12 @@ //===----------------------------------------------------------------------===// #include "flang/Runtime/assign.h" -#include "derived.h" -#include "stat.h" +#include "assign-object.h" #include "terminator.h" -#include "type-info.h" #include "flang/Runtime/descriptor.h" namespace Fortran::runtime { -static void DoScalarDefinedAssignment(const Descriptor &to, - const Descriptor &from, const typeInfo::SpecialBinding &special) { - bool toIsDesc{special.IsArgDescriptor(0)}; - bool fromIsDesc{special.IsArgDescriptor(1)}; - if (toIsDesc) { - if (fromIsDesc) { - auto *p{ - special.GetProc()}; - p(to, from); - } else { - auto *p{special.GetProc()}; - p(to, from.raw().base_addr); - } - } else { - if (fromIsDesc) { - auto *p{special.GetProc()}; - p(to.raw().base_addr, from); - } else { - auto *p{special.GetProc()}; - p(to.raw().base_addr, from.raw().base_addr); - } - } -} - -static void DoElementalDefinedAssignment(const Descriptor &to, - const Descriptor &from, const typeInfo::SpecialBinding &special, - std::size_t toElements, SubscriptValue toAt[], SubscriptValue fromAt[]) { - StaticDescriptor statDesc[2]; - Descriptor &toElementDesc{statDesc[0].descriptor()}; - Descriptor &fromElementDesc{statDesc[1].descriptor()}; - toElementDesc = to; - toElementDesc.raw().attribute = CFI_attribute_pointer; - toElementDesc.raw().rank = 0; - fromElementDesc = from; - fromElementDesc.raw().attribute = CFI_attribute_pointer; - fromElementDesc.raw().rank = 0; - for (std::size_t j{0}; j < toElements; - ++j, to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { - toElementDesc.set_base_addr(to.Element(toAt)); - fromElementDesc.set_base_addr(from.Element(fromAt)); - DoScalarDefinedAssignment(toElementDesc, fromElementDesc, special); - } -} - -void Assign(Descriptor &to, const Descriptor &from, Terminator &terminator) { - DescriptorAddendum *toAddendum{to.Addendum()}; - const typeInfo::DerivedType *toDerived{ - toAddendum ? toAddendum->derivedType() : nullptr}; - const DescriptorAddendum *fromAddendum{from.Addendum()}; - const typeInfo::DerivedType *fromDerived{ - fromAddendum ? fromAddendum->derivedType() : nullptr}; - bool wasJustAllocated{false}; - if (to.IsAllocatable()) { - std::size_t lenParms{fromDerived ? fromDerived->LenParameters() : 0}; - if (to.IsAllocated()) { - // 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). - bool deallocate{false}; - if (to.type() != from.type()) { - deallocate = true; - } else if (toDerived != fromDerived) { - deallocate = true; - } else { - if (toAddendum) { - // Distinct LEN parameters? Deallocate - for (std::size_t j{0}; j < lenParms; ++j) { - if (toAddendum->LenParameterValue(j) != - fromAddendum->LenParameterValue(j)) { - deallocate = true; - break; - } - } - } - if (from.rank() > 0) { - // Distinct shape? Deallocate - int rank{to.rank()}; - for (int j{0}; j < rank; ++j) { - if (to.GetDimension(j).Extent() != from.GetDimension(j).Extent()) { - deallocate = true; - break; - } - } - } - } - if (deallocate) { - to.Destroy(true /*finalize*/); - } - } else if (to.rank() != from.rank()) { - terminator.Crash("Assign: mismatched ranks (%d != %d) in assignment to " - "unallocated allocatable", - to.rank(), from.rank()); - } - if (!to.IsAllocated()) { - to.raw().type = from.raw().type; - to.raw().elem_len = from.ElementBytes(); - if (toAddendum) { - toDerived = fromDerived; - toAddendum->set_derivedType(toDerived); - for (std::size_t j{0}; j < lenParms; ++j) { - toAddendum->SetLenParameterValue( - j, fromAddendum->LenParameterValue(j)); - } - } - // subtle: leave bounds in place when "from" is scalar (10.2.1.3(3)) - int rank{from.rank()}; - auto stride{static_cast(to.ElementBytes())}; - for (int j{0}; j < rank; ++j) { - auto &toDim{to.GetDimension(j)}; - const auto &fromDim{from.GetDimension(j)}; - toDim.SetBounds(fromDim.LowerBound(), fromDim.UpperBound()); - toDim.SetByteStride(stride); - stride *= toDim.Extent(); - } - ReturnError(terminator, to.Allocate()); - if (fromDerived && !fromDerived->noInitializationNeeded()) { - ReturnError(terminator, Initialize(to, *toDerived, terminator)); - } - wasJustAllocated = true; - } - } - SubscriptValue toAt[maxRank]; - to.GetLowerBounds(toAt); - // Scalar expansion of the RHS is implied by using the same empty - // subscript values on each (seemingly) elemental reference into - // "from". - SubscriptValue fromAt[maxRank]; - from.GetLowerBounds(fromAt); - std::size_t toElements{to.Elements()}; - if (from.rank() > 0 && toElements != from.Elements()) { - terminator.Crash("Assign: mismatching element counts in array assignment " - "(to %zd, from %zd)", - toElements, from.Elements()); - } - if (to.type() != from.type()) { - terminator.Crash("Assign: mismatching types (to code %d != from code %d)", - to.type().raw(), from.type().raw()); - } - std::size_t elementBytes{to.ElementBytes()}; - if (elementBytes != from.ElementBytes()) { - terminator.Crash( - "Assign: mismatching element sizes (to %zd bytes != from %zd bytes)", - elementBytes, from.ElementBytes()); - } - if (toDerived) { // Derived type assignment - // Check for defined assignment type-bound procedures (10.2.1.4-5) - if (to.rank() == 0) { - if (const auto *special{toDerived->FindSpecialBinding( - typeInfo::SpecialBinding::Which::ScalarAssignment)}) { - return DoScalarDefinedAssignment(to, from, *special); - } - } - if (const auto *special{toDerived->FindSpecialBinding( - typeInfo::SpecialBinding::Which::ElementalAssignment)}) { - return DoElementalDefinedAssignment( - to, from, *special, toElements, toAt, fromAt); - } - // Derived type intrinsic assignment, which is componentwise and elementwise - // for all components, including parent components (10.2.1.2-3). - // The target is first finalized if still necessary (7.5.6.3(1)) - if (!wasJustAllocated && !toDerived->noFinalizationNeeded()) { - Finalize(to, *toDerived); - } - // Copy the data components (incl. the parent) first. - const Descriptor &componentDesc{toDerived->component()}; - std::size_t numComponents{componentDesc.Elements()}; - for (std::size_t k{0}; k < numComponents; ++k) { - const auto &comp{ - *componentDesc.ZeroBasedIndexedElement( - k)}; // TODO: exploit contiguity here - switch (comp.genre()) { - case typeInfo::Component::Genre::Data: - if (comp.category() == TypeCategory::Derived) { - StaticDescriptor statDesc[2]; - Descriptor &toCompDesc{statDesc[0].descriptor()}; - Descriptor &fromCompDesc{statDesc[1].descriptor()}; - for (std::size_t j{0}; j < toElements; ++j, - to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { - comp.CreatePointerDescriptor(toCompDesc, to, terminator, toAt); - comp.CreatePointerDescriptor( - fromCompDesc, from, terminator, fromAt); - Assign(toCompDesc, fromCompDesc, terminator); - } - } else { // Component has intrinsic type; simply copy raw bytes - std::size_t componentByteSize{comp.SizeInBytes(to)}; - for (std::size_t j{0}; j < toElements; ++j, - to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { - std::memmove(to.Element(toAt) + comp.offset(), - from.Element(fromAt) + comp.offset(), - componentByteSize); - } - } - break; - case typeInfo::Component::Genre::Pointer: { - std::size_t componentByteSize{comp.SizeInBytes(to)}; - for (std::size_t j{0}; j < toElements; ++j, - to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { - std::memmove(to.Element(toAt) + comp.offset(), - from.Element(fromAt) + comp.offset(), - componentByteSize); - } - } break; - case typeInfo::Component::Genre::Allocatable: - case typeInfo::Component::Genre::Automatic: - for (std::size_t j{0}; j < toElements; ++j, - to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { - auto *toDesc{reinterpret_cast( - to.Element(toAt) + comp.offset())}; - const auto *fromDesc{reinterpret_cast( - from.Element(fromAt) + comp.offset())}; - if (toDesc->IsAllocatable()) { - if (toDesc->IsAllocated()) { - // Allocatable components of the LHS are unconditionally - // deallocated before assignment (F'2018 10.2.1.3(13)(1)), - // unlike a "top-level" assignment to a variable, where - // deallocation is optional. - // TODO: Consider skipping this step and deferring the - // deallocation to the recursive activation of Assign(), - // which might be able to avoid deallocation/reallocation - // when the existing allocation can be reoccupied. - toDesc->Destroy(false /*already finalized*/); - } - if (!fromDesc->IsAllocated()) { - continue; // F'2018 10.2.1.3(13)(2) - } - } - Assign(*toDesc, *fromDesc, terminator); - } - break; - } - } - // Copy procedure pointer components - const Descriptor &procPtrDesc{toDerived->procPtr()}; - std::size_t numProcPtrs{procPtrDesc.Elements()}; - for (std::size_t k{0}; k < numProcPtrs; ++k) { - const auto &procPtr{ - *procPtrDesc.ZeroBasedIndexedElement(k)}; - for (std::size_t j{0}; j < toElements; ++j, to.IncrementSubscripts(toAt), - from.IncrementSubscripts(fromAt)) { - std::memmove(to.Element(toAt) + procPtr.offset, - from.Element(fromAt) + procPtr.offset, - sizeof(typeInfo::ProcedurePointer)); - } - } - } else { // intrinsic type, intrinsic assignment - if (to.rank() == from.rank() && to.IsContiguous() && from.IsContiguous()) { - // Everything is contiguous; do a single big copy - std::memmove( - to.raw().base_addr, from.raw().base_addr, toElements * elementBytes); - } else { // elemental copies - for (std::size_t n{toElements}; n-- > 0; - to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) { - std::memmove(to.Element(toAt), from.Element(fromAt), - elementBytes); - } - } - } -} - extern "C" { void RTNAME(Assign)(Descriptor &to, const Descriptor &from, const char *sourceFile, int sourceLine) { Index: flang/runtime/pointer.cpp =================================================================== --- flang/runtime/pointer.cpp +++ flang/runtime/pointer.cpp @@ -7,6 +7,7 @@ //===----------------------------------------------------------------------===// #include "flang/Runtime/pointer.h" +#include "assign-object.h" #include "derived.h" #include "stat.h" #include "terminator.h" @@ -132,6 +133,22 @@ 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}; @@ -174,7 +191,7 @@ return true; } -// TODO: PointerCheckLengthParameter, PointerAllocateSource +// TODO: PointerCheckLengthParameter } // extern "C" } // namespace Fortran::runtime Index: flang/test/Lower/allocate-source-allocatables.f90 =================================================================== --- /dev/null +++ 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_20]] : 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_20]] : (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 Index: flang/test/Lower/allocate-source-pointers.f90 =================================================================== --- /dev/null +++ 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_19]] : 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_19]] : (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