diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h index f2f37866ecde8..82c31c0c40430 100644 --- a/flang/include/flang/Evaluate/characteristics.h +++ b/flang/include/flang/Evaluate/characteristics.h @@ -177,6 +177,14 @@ class TypeAndShape { int corank() const { return corank_; } int Rank() const { return GetRank(shape_); } + + // Can sequence association apply to this argument? + bool CanBeSequenceAssociated() const { + constexpr Attrs notAssumedOrExplicitShape{ + ~Attrs{Attr::AssumedSize, Attr::Coarray}}; + return Rank() > 0 && (attrs() & notAssumedOrExplicitShape).none(); + } + bool IsCompatibleWith(parser::ContextualMessages &, const TypeAndShape &that, const char *thisIs = "pointer", const char *thatIs = "target", bool omitShapeConformanceCheck = false, diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h index e77ac4e179ba8..80b0576425377 100644 --- a/flang/include/flang/Lower/CallInterface.h +++ b/flang/include/flang/Lower/CallInterface.h @@ -174,6 +174,12 @@ class CallInterface { /// May the dummy argument require INTENT(OUT) finalization /// on entry to the invoked procedure? Provides conservative answer. bool mayRequireIntentoutFinalization() const; + /// Is the dummy argument an explicit-shape or assumed-size array that + /// must be passed by descriptor? Sequence association imply the actual + /// argument shape/rank may differ with the dummy shape/rank (see F'2023 + /// section 15.5.2.12), so care is needed when creating the descriptor + /// for the dummy argument. + bool isSequenceAssociatedDescriptor() const; /// How entity is passed by. PassEntityBy passBy; /// What is the entity (SymbolRef for callee/ActualArgument* for caller) @@ -273,8 +279,6 @@ class CallerInterface : public CallInterface { actualInputs.resize(getNumFIRArguments()); } - using ExprVisitor = std::function)>; - /// CRTP callbacks bool hasAlternateReturns() const; std::string getMangledName() const; @@ -312,12 +316,21 @@ class CallerInterface : public CallInterface { /// procedure. const Fortran::semantics::Symbol *getProcedureSymbol() const; + /// Return the dummy argument symbol if this is a call to a user + /// defined procedure with explicit interface. Returns nullptr if there + /// is no user defined explicit interface. + const Fortran::semantics::Symbol * + getDummySymbol(const PassedEntity &entity) const; + /// Helpers to place the lowered arguments at the right place once they /// have been lowered. void placeInput(const PassedEntity &passedEntity, mlir::Value arg); void placeAddressAndLengthInput(const PassedEntity &passedEntity, mlir::Value addr, mlir::Value len); + /// Get lowered FIR argument given the Fortran argument. + mlir::Value getInput(const PassedEntity &passedEntity); + /// If this is a call to a procedure pointer or dummy, returns the related /// procedure designator. Nullptr otherwise. const Fortran::evaluate::ProcedureDesignator *getIfIndirectCall() const; @@ -333,13 +346,27 @@ class CallerInterface : public CallInterface { /// the result specification expressions (extents and lengths) ? If needed, /// this mapping must be done after argument lowering, and before the call /// itself. - bool mustMapInterfaceSymbols() const; + bool mustMapInterfaceSymbolsForResult() const; + /// Must the caller map function interface symbols in order to evaluate + /// the specification expressions of a given dummy argument? + bool mustMapInterfaceSymbolsForDummyArgument(const PassedEntity &) const; + + /// Visitor for specification expression. Boolean indicate the specification + /// expression is for the last extent of an assumed size array. + using ExprVisitor = + std::function, bool)>; /// Walk the result non-deferred extent specification expressions. - void walkResultExtents(ExprVisitor) const; + void walkResultExtents(const ExprVisitor &) const; /// Walk the result non-deferred length specification expressions. - void walkResultLengths(ExprVisitor) const; + void walkResultLengths(const ExprVisitor &) const; + /// Walk non-deferred extent specification expressions of a dummy argument. + void walkDummyArgumentExtents(const PassedEntity &, + const ExprVisitor &) const; + /// Walk non-deferred length specification expressions of a dummy argument. + void walkDummyArgumentLengths(const PassedEntity &, + const ExprVisitor &) const; /// Get the mlir::Value that is passed as argument \p sym of the function /// being called. The arguments must have been placed before calling this @@ -355,6 +382,9 @@ class CallerInterface : public CallInterface { /// returns the storage type. mlir::Type getResultStorageType() const; + /// Return FIR type of argument. + mlir::Type getDummyArgumentType(const PassedEntity &) const; + // Copy of base implementation. static constexpr bool hasHostAssociated() { return false; } mlir::Type getHostAssociatedTy() const { diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h index b13bb412f0f3e..ab30e317d1d9d 100644 --- a/flang/include/flang/Lower/ConvertVariable.h +++ b/flang/include/flang/Lower/ConvertVariable.h @@ -93,9 +93,16 @@ void mapSymbolAttributes(AbstractConverter &, const semantics::SymbolRef &, /// Instantiate the variables that appear in the specification expressions /// of the result of a function call. The instantiated variables are added /// to \p symMap. -void mapCallInterfaceSymbols(AbstractConverter &, - const Fortran::lower::CallerInterface &caller, - SymMap &symMap); +void mapCallInterfaceSymbolsForResult( + AbstractConverter &, const Fortran::lower::CallerInterface &caller, + SymMap &symMap); + +/// Instantiate the variables that appear in the specification expressions +/// of a dummy argument of a procedure call. The instantiated variables are +/// added to \p symMap. +void mapCallInterfaceSymbolsForDummyArgument( + AbstractConverter &, const Fortran::lower::CallerInterface &caller, + SymMap &symMap, const Fortran::semantics::Symbol &dummySymbol); // TODO: consider saving the initial expression symbol dependence analysis in // in the PFT variable and dealing with the dependent symbols instantiation in diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp index 6b71aabf7fdc8..2f95d53c383b9 100644 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -310,21 +310,22 @@ bool Fortran::lower::CallerInterface::verifyActualInputs() const { return true; } -void Fortran::lower::CallerInterface::walkResultLengths( - ExprVisitor visitor) const { - assert(characteristic && "characteristic was not computed"); - const Fortran::evaluate::characteristics::FunctionResult &result = - characteristic->functionResult.value(); - const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape = - result.GetTypeAndShape(); - assert(typeAndShape && "no result type"); - Fortran::evaluate::DynamicType dynamicType = typeAndShape->type(); - // Visit result length specification expressions that are explicit. +mlir::Value +Fortran::lower::CallerInterface::getInput(const PassedEntity &passedEntity) { + return actualInputs[passedEntity.firArgument]; +} + +static void walkLengths( + const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape, + const Fortran::lower::CallerInterface::ExprVisitor &visitor, + Fortran::lower::AbstractConverter &converter) { + Fortran::evaluate::DynamicType dynamicType = typeAndShape.type(); + // Visit length specification expressions that are explicit. if (dynamicType.category() == Fortran::common::TypeCategory::Character) { if (std::optional length = dynamicType.GetCharLength()) - visitor(toEvExpr(*length)); - } else if (dynamicType.category() == common::TypeCategory::Derived && + visitor(toEvExpr(*length), /*assumedSize=*/false); + } else if (dynamicType.category() == Fortran::common::TypeCategory::Derived && !dynamicType.IsUnlimitedPolymorphic()) { const Fortran::semantics::DerivedTypeSpec &derivedTypeSpec = dynamicType.GetDerivedTypeSpec(); @@ -334,11 +335,33 @@ void Fortran::lower::CallerInterface::walkResultLengths( } } +void Fortran::lower::CallerInterface::walkResultLengths( + const ExprVisitor &visitor) const { + assert(characteristic && "characteristic was not computed"); + const Fortran::evaluate::characteristics::FunctionResult &result = + characteristic->functionResult.value(); + const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape = + result.GetTypeAndShape(); + assert(typeAndShape && "no result type"); + return walkLengths(*typeAndShape, visitor, converter); +} + +void Fortran::lower::CallerInterface::walkDummyArgumentLengths( + const PassedEntity &passedEntity, const ExprVisitor &visitor) const { + if (!passedEntity.characteristics) + return; + if (const auto *dummy = + std::get_if( + &passedEntity.characteristics->u)) + walkLengths(dummy->type, visitor, converter); +} + // Compute extent expr from shapeSpec of an explicit shape. -// TODO: Allow evaluate shape analysis to work in a mode where it disregards -// the non-constant aspects when building the shape to avoid having this here. static Fortran::evaluate::ExtentExpr getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) { + if (shapeSpec.ubound().isStar()) + // F'2023 18.5.3 point 5. + return Fortran::evaluate::ExtentExpr{-1}; const auto &ubound = shapeSpec.ubound().GetExplicit(); const auto &lbound = shapeSpec.lbound().GetExplicit(); assert(lbound && ubound && "shape must be explicit"); @@ -346,20 +369,27 @@ getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) { Fortran::evaluate::ExtentExpr{1}; } +static void +walkExtents(const Fortran::semantics::Symbol &symbol, + const Fortran::lower::CallerInterface::ExprVisitor &visitor) { + if (const auto *objectDetails = + symbol.detailsIf()) + if (objectDetails->shape().IsExplicitShape() || + Fortran::semantics::IsAssumedSizeArray(symbol)) + for (const Fortran::semantics::ShapeSpec &shapeSpec : + objectDetails->shape()) + visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec)), + /*assumedSize=*/shapeSpec.ubound().isStar()); +} + void Fortran::lower::CallerInterface::walkResultExtents( - ExprVisitor visitor) const { + const ExprVisitor &visitor) const { // Walk directly the result symbol shape (the characteristic shape may contain // descriptor inquiries to it that would fail to lower on the caller side). const Fortran::semantics::SubprogramDetails *interfaceDetails = getInterfaceDetails(); if (interfaceDetails) { - const Fortran::semantics::Symbol &result = interfaceDetails->result(); - if (const auto *objectDetails = - result.detailsIf()) - if (objectDetails->shape().IsExplicitShape()) - for (const Fortran::semantics::ShapeSpec &shapeSpec : - objectDetails->shape()) - visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec))); + walkExtents(interfaceDetails->result(), visitor); } else { if (procRef.Rank() != 0) fir::emitFatalError( @@ -368,7 +398,18 @@ void Fortran::lower::CallerInterface::walkResultExtents( } } -bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const { +void Fortran::lower::CallerInterface::walkDummyArgumentExtents( + const PassedEntity &passedEntity, const ExprVisitor &visitor) const { + const Fortran::semantics::SubprogramDetails *interfaceDetails = + getInterfaceDetails(); + if (!interfaceDetails) + return; + const Fortran::semantics::Symbol *dummy = getDummySymbol(passedEntity); + assert(dummy && "dummy symbol was not set"); + walkExtents(*dummy, visitor); +} + +bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForResult() const { assert(characteristic && "characteristic was not computed"); const std::optional &result = characteristic->functionResult; @@ -376,7 +417,7 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const { !getInterfaceDetails() || result->IsProcedurePointer()) return false; bool allResultSpecExprConstant = true; - auto visitor = [&](const Fortran::lower::SomeExpr &e) { + auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) { allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e); }; walkResultLengths(visitor); @@ -384,6 +425,17 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const { return !allResultSpecExprConstant; } +bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForDummyArgument( + const PassedEntity &arg) const { + bool allResultSpecExprConstant = true; + auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) { + allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e); + }; + walkDummyArgumentLengths(arg, visitor); + walkDummyArgumentExtents(arg, visitor); + return !allResultSpecExprConstant; +} + mlir::Value Fortran::lower::CallerInterface::getArgumentValue( const semantics::Symbol &sym) const { mlir::Location loc = converter.getCurrentLocation(); @@ -401,6 +453,24 @@ mlir::Value Fortran::lower::CallerInterface::getArgumentValue( return actualInputs[mlirArgIndex]; } +const Fortran::semantics::Symbol * +Fortran::lower::CallerInterface::getDummySymbol( + const PassedEntity &passedEntity) const { + const Fortran::semantics::SubprogramDetails *ifaceDetails = + getInterfaceDetails(); + if (!ifaceDetails) + return nullptr; + std::size_t argPosition = 0; + for (const auto &arg : getPassedArguments()) { + if (&arg == &passedEntity) + break; + ++argPosition; + } + if (argPosition >= ifaceDetails->dummyArgs().size()) + return nullptr; + return ifaceDetails->dummyArgs()[argPosition]; +} + mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const { if (passedResult) return fir::dyn_cast_ptrEleTy(inputs[passedResult->firArgument].type); @@ -408,6 +478,11 @@ mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const { return outputs[0].type; } +mlir::Type Fortran::lower::CallerInterface::getDummyArgumentType( + const PassedEntity &passedEntity) const { + return inputs[passedEntity.firArgument].type; +} + const Fortran::semantics::Symbol & Fortran::lower::CallerInterface::getResultSymbol() const { mlir::Location loc = converter.getCurrentLocation(); @@ -1387,6 +1462,17 @@ bool Fortran::lower::CallInterface< return Fortran::semantics::IsFinalizable(*derived); } +template +bool Fortran::lower::CallInterface< + T>::PassedEntity::isSequenceAssociatedDescriptor() const { + if (!characteristics || passBy != PassEntityBy::Box) + return false; + const auto *dummy = + std::get_if( + &characteristics->u); + return dummy && dummy->type.CanBeSequenceAssociated(); +} + template void Fortran::lower::CallInterface::determineInterface( bool isImplicit, diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp index 95569337a06e9..6eba243c237cf 100644 --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -164,6 +164,125 @@ static mlir::Value readDim3Value(fir::FirOpBuilder &builder, mlir::Location loc, return hlfir::loadTrivialScalar(loc, builder, hlfir::Entity{designate}); } +static mlir::Value remapActualToDummyDescriptor( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, + const Fortran::lower::CallerInterface::PassedEntity &arg, + Fortran::lower::CallerInterface &caller, bool isBindcCall) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + mlir::IndexType idxTy = builder.getIndexType(); + mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0); + Fortran::lower::StatementContext localStmtCtx; + auto lowerSpecExpr = [&](const auto &expr, + bool isAssumedSizeExtent) -> mlir::Value { + mlir::Value convertExpr = builder.createConvert( + loc, idxTy, fir::getBase(converter.genExprValue(expr, localStmtCtx))); + if (isAssumedSizeExtent) + return convertExpr; + return fir::factory::genMaxWithZero(builder, loc, convertExpr); + }; + bool mapSymbols = caller.mustMapInterfaceSymbolsForDummyArgument(arg); + if (mapSymbols) { + symMap.pushScope(); + const Fortran::semantics::Symbol *sym = caller.getDummySymbol(arg); + assert(sym && "call must have explicit interface to map interface symbols"); + Fortran::lower::mapCallInterfaceSymbolsForDummyArgument(converter, caller, + symMap, *sym); + } + llvm::SmallVector extents; + llvm::SmallVector lengths; + mlir::Type dummyBoxType = caller.getDummyArgumentType(arg); + mlir::Type dummyBaseType = fir::unwrapPassByRefType(dummyBoxType); + if (dummyBaseType.isa()) + caller.walkDummyArgumentExtents( + arg, [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) { + extents.emplace_back(lowerSpecExpr(e, isAssumedSizeExtent)); + }); + mlir::Value shape; + if (!extents.empty()) { + if (isBindcCall) { + // Preserve zero lower bounds (see F'2023 18.5.3). + llvm::SmallVector lowerBounds(extents.size(), zero); + shape = builder.genShape(loc, lowerBounds, extents); + } else { + shape = builder.genShape(loc, extents); + } + } + + hlfir::Entity explicitArgument = hlfir::Entity{caller.getInput(arg)}; + mlir::Type dummyElementType = fir::unwrapSequenceType(dummyBaseType); + if (auto recType = llvm::dyn_cast(dummyElementType)) + if (recType.getNumLenParams() > 0) + TODO(loc, "sequence association of length parameterized derived type " + "dummy arguments"); + if (fir::isa_char(dummyElementType)) + lengths.emplace_back(hlfir::genCharLength(loc, builder, explicitArgument)); + mlir::Value baseAddr = + hlfir::genVariableRawAddress(loc, builder, explicitArgument); + baseAddr = builder.createConvert(loc, fir::ReferenceType::get(dummyBaseType), + baseAddr); + mlir::Value mold; + if (fir::isPolymorphicType(dummyBoxType)) + mold = explicitArgument; + mlir::Value remapped = + builder.create(loc, dummyBoxType, baseAddr, shape, + /*slice=*/mlir::Value{}, lengths, mold); + if (mapSymbols) + symMap.popScope(); + return remapped; +} + +/// Create a descriptor for sequenced associated descriptor that are passed +/// by descriptor. Sequence association (F'2023 15.5.2.12) implies that the +/// dummy shape and rank need to not be the same as the actual argument. This +/// helper creates a descriptor based on the dummy shape and rank (sequence +/// association can only happen with explicit and assumed-size array) so that it +/// is safe to assume the rank of the incoming descriptor inside the callee. +/// This helper must be called once all the actual arguments have been lowered +/// and placed inside "caller". Copy-in/copy-out must already have been +/// generated if needed using the actual argument shape (the dummy shape may be +/// assumed-size). +static void remapActualToDummyDescriptors( + mlir::Location loc, Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &symMap, + const Fortran::lower::PreparedActualArguments &loweredActuals, + Fortran::lower::CallerInterface &caller, bool isBindcCall) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + for (auto [preparedActual, arg] : + llvm::zip(loweredActuals, caller.getPassedArguments())) { + if (arg.isSequenceAssociatedDescriptor()) { + if (!preparedActual.value().handleDynamicOptional()) { + mlir::Value remapped = remapActualToDummyDescriptor( + loc, converter, symMap, arg, caller, isBindcCall); + caller.placeInput(arg, remapped); + } else { + // Absent optional actual argument descriptor cannot be read and + // remapped unconditionally. + mlir::Type dummyType = caller.getDummyArgumentType(arg); + mlir::Value isPresent = preparedActual.value().getIsPresent(); + auto &argLambdaCapture = arg; + mlir::Value remapped = + builder + .genIfOp(loc, {dummyType}, isPresent, + /*withElseRegion=*/true) + .genThen([&]() { + mlir::Value newBox = remapActualToDummyDescriptor( + loc, converter, symMap, argLambdaCapture, caller, + isBindcCall); + builder.create(loc, newBox); + }) + .genElse([&]() { + mlir::Value absent = + builder.create(loc, dummyType); + builder.create(loc, absent); + }) + .getResults()[0]; + caller.placeInput(arg, remapped); + } + } + } +} + std::pair Fortran::lower::genCallOpAndResult( mlir::Location loc, Fortran::lower::AbstractConverter &converter, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, @@ -171,12 +290,11 @@ std::pair Fortran::lower::genCallOpAndResult( std::optional resultType, bool isElemental) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); using PassBy = Fortran::lower::CallerInterface::PassEntityBy; - // Handle cases where caller must allocate the result or a fir.box for it. bool mustPopSymMap = false; - if (caller.mustMapInterfaceSymbols()) { + if (caller.mustMapInterfaceSymbolsForResult()) { symMap.pushScope(); mustPopSymMap = true; - Fortran::lower::mapCallInterfaceSymbols(converter, caller, symMap); + Fortran::lower::mapCallInterfaceSymbolsForResult(converter, caller, symMap); } // If this is an indirect call, retrieve the function address. Also retrieve // the result length if this is a character function (note that this length @@ -221,12 +339,16 @@ std::pair Fortran::lower::genCallOpAndResult( return {}; mlir::Type type = caller.getResultStorageType(); if (type.isa()) - caller.walkResultExtents([&](const Fortran::lower::SomeExpr &e) { - extents.emplace_back(lowerSpecExpr(e)); - }); - caller.walkResultLengths([&](const Fortran::lower::SomeExpr &e) { - lengths.emplace_back(lowerSpecExpr(e)); - }); + caller.walkResultExtents( + [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) { + assert(!isAssumedSizeExtent && "result cannot be assumed-size"); + extents.emplace_back(lowerSpecExpr(e)); + }); + caller.walkResultLengths( + [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) { + assert(!isAssumedSizeExtent && "result cannot be assumed-size"); + lengths.emplace_back(lowerSpecExpr(e)); + }); // Result length parameters should not be provided to box storage // allocation and save_results, but they are still useful information to @@ -1056,10 +1178,16 @@ static PreparedDummyArgument preparePresentUserCallActualArgument( // Create dummy type with actual argument rank when the dummy is an assumed // rank. That way, all the operation to create dummy descriptors are ranked if // the actual argument is ranked, which allows simple code generation. + // Also do the same when the dummy is a sequence associated descriptor + // because the actual shape/rank may mismatch with the dummy, and the dummy + // may be an assumed-size array, so any descriptor manipulation should use the + // actual argument shape information. A descriptor with the dummy shape + // information will be created later when all actual arguments are ready. mlir::Type dummyTypeWithActualRank = dummyType; if (auto baseBoxDummy = mlir::dyn_cast(dummyType)) if (baseBoxDummy.isAssumedRank() || - arg.testTKR(Fortran::common::IgnoreTKR::Rank)) + arg.testTKR(Fortran::common::IgnoreTKR::Rank) || + arg.isSequenceAssociatedDescriptor()) dummyTypeWithActualRank = baseBoxDummy.getBoxTypeWithNewShape(actual.getType()); // Preserve the actual type in the argument preparation in case IgnoreTKR(t) @@ -1342,6 +1470,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals, mlir::FunctionType callSiteType, CallContext &callContext) { using PassBy = Fortran::lower::CallerInterface::PassEntityBy; mlir::Location loc = callContext.loc; + bool mustRemapActualToDummyDescriptors = false; fir::FirOpBuilder &builder = callContext.getBuilder(); llvm::SmallVector callCleanUps; for (auto [preparedActual, arg] : @@ -1398,6 +1527,9 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals, callCleanUps.append(preparedDummy.cleanups.rbegin(), preparedDummy.cleanups.rend()); caller.placeInput(arg, preparedDummy.dummy); + if (arg.passBy == PassBy::Box) + mustRemapActualToDummyDescriptors |= + arg.isSequenceAssociatedDescriptor(); } break; case PassBy::BoxProcRef: { PreparedDummyArgument preparedDummy = @@ -1490,6 +1622,12 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals, } break; } } + // Handle cases where caller must allocate the result or a fir.box for it. + if (mustRemapActualToDummyDescriptors) + remapActualToDummyDescriptors(loc, callContext.converter, + callContext.symMap, loweredActuals, caller, + callContext.isBindcCall()); + // Prepare lowered arguments according to the interface // and map the lowered values to the dummy // arguments. diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp index a673a18cd20d9..94d849862099e 100644 --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -2260,19 +2260,20 @@ void Fortran::lower::instantiateVariable(AbstractConverter &converter, instantiateLocal(converter, var, symMap); } -void Fortran::lower::mapCallInterfaceSymbols( - AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, - SymMap &symMap) { +static void +mapCallInterfaceSymbol(const Fortran::semantics::Symbol &interfaceSymbol, + Fortran::lower::AbstractConverter &converter, + const Fortran::lower::CallerInterface &caller, + Fortran::lower::SymMap &symMap) { Fortran::lower::AggregateStoreMap storeMap; - const Fortran::semantics::Symbol &result = caller.getResultSymbol(); for (Fortran::lower::pft::Variable var : - Fortran::lower::pft::getDependentVariableList(result)) { + Fortran::lower::pft::getDependentVariableList(interfaceSymbol)) { if (var.isAggregateStore()) { instantiateVariable(converter, var, symMap, storeMap); continue; } const Fortran::semantics::Symbol &sym = var.getSymbol(); - if (&sym == &result) + if (&sym == &interfaceSymbol) continue; const auto *hostDetails = sym.detailsIf(); @@ -2293,7 +2294,8 @@ void Fortran::lower::mapCallInterfaceSymbols( // instantiateVariable that would try to allocate a new storage. continue; } - if (Fortran::semantics::IsDummy(sym) && sym.owner() == result.owner()) { + if (Fortran::semantics::IsDummy(sym) && + sym.owner() == interfaceSymbol.owner()) { // Get the argument for the dummy argument symbols of the current call. symMap.addSymbol(sym, caller.getArgumentValue(sym)); // All the properties of the dummy variable may not come from the actual @@ -2307,6 +2309,19 @@ void Fortran::lower::mapCallInterfaceSymbols( } } +void Fortran::lower::mapCallInterfaceSymbolsForResult( + AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, + SymMap &symMap) { + const Fortran::semantics::Symbol &result = caller.getResultSymbol(); + mapCallInterfaceSymbol(result, converter, caller, symMap); +} + +void Fortran::lower::mapCallInterfaceSymbolsForDummyArgument( + AbstractConverter &converter, const Fortran::lower::CallerInterface &caller, + SymMap &symMap, const Fortran::semantics::Symbol &dummySymbol) { + mapCallInterfaceSymbol(dummySymbol, converter, caller, symMap); +} + void Fortran::lower::mapSymbolAttributes( AbstractConverter &converter, const Fortran::semantics::SymbolRef &symbol, Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx, diff --git a/flang/test/Lower/HLFIR/call-sequence-associated-descriptors.f90 b/flang/test/Lower/HLFIR/call-sequence-associated-descriptors.f90 new file mode 100644 index 0000000000000..9cbb9279a868d --- /dev/null +++ b/flang/test/Lower/HLFIR/call-sequence-associated-descriptors.f90 @@ -0,0 +1,309 @@ +! Test lowering of sequence associated arguments (F'2023 15.5.2.12) passed +! by descriptor. The descriptor on the caller side is prepared according to +! the dummy argument shape. +! RUN: bbc -emit-hlfir -polymorphic-type -o - %s | FileCheck %s + +module bindc_seq_assoc + interface + subroutine takes_char(x, n) bind(c) + integer :: n + character(*) :: x(n) + end subroutine + subroutine takes_char_assumed_size(x) bind(c) + character(*) :: x(10, *) + end subroutine + subroutine takes_optional_char(x, n) bind(c) + integer :: n + character(*), optional :: x(n) + end subroutine + end interface +contains + subroutine test_char_1(x) + character(*) :: x(10, 20) + call takes_char(x, 100) + end subroutine +! CHECK-LABEL: func.func @_QMbindc_seq_assocPtest_char_1( +! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_2:.*]](%[[VAL_5:.*]]) typeparams %[[VAL_1:.*]]#1 {uniq_name = "_QMbindc_seq_assocFtest_char_1Ex"} : (!fir.ref>>, !fir.shape<2>, index) -> (!fir.box>>, !fir.ref>>) +! CHECK: %[[VAL_7:.*]] = arith.constant 100 : i32 +! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_9:.*]] = fir.shift %[[VAL_8]], %[[VAL_8]] : (index, index) -> !fir.shift<2> +! CHECK: %[[VAL_10:.*]] = fir.rebox %[[VAL_6]]#0(%[[VAL_9]]) : (!fir.box>>, !fir.shift<2>) -> !fir.box>> +! CHECK: %[[VAL_11:.*]]:3 = hlfir.associate %[[VAL_7]] {adapt.valuebyref} : (i32) -> (!fir.ref, !fir.ref, i1) +! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_13:.*]]:2 = hlfir.declare %[[VAL_11]]#1 {uniq_name = "_QMbindc_seq_assocFtakes_charEn"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_13]]#0 : !fir.ref +! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i32) -> i64 +! CHECK: %[[VAL_16:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_17:.*]] = arith.subi %[[VAL_15]], %[[VAL_16]] : i64 +! CHECK: %[[VAL_18:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_19:.*]] = arith.addi %[[VAL_17]], %[[VAL_18]] : 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.shape_shift %[[VAL_12]], %[[VAL_23]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_25:.*]] = fir.box_elesize %[[VAL_10]] : (!fir.box>>) -> index +! CHECK: %[[VAL_26:.*]] = fir.box_addr %[[VAL_10]] : (!fir.box>>) -> !fir.ref>> +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_26]] : (!fir.ref>>) -> !fir.ref>> +! CHECK: %[[VAL_28:.*]] = fir.embox %[[VAL_27]](%[[VAL_24]]) typeparams %[[VAL_25]] : (!fir.ref>>, !fir.shapeshift<1>, index) -> !fir.box>> +! CHECK: fir.call @takes_char(%[[VAL_28]], %[[VAL_11]]#1) fastmath : (!fir.box>>, !fir.ref) -> () +! CHECK: hlfir.end_associate %[[VAL_11]]#1, %[[VAL_11]]#2 : !fir.ref, i1 +! CHECK: return +! CHECK: } + + subroutine test_char_copy_in_copy_out(x) + character(*) :: x(:, :) + call takes_char(x, 100) + end subroutine +! CHECK-LABEL: func.func @_QMbindc_seq_assocPtest_char_copy_in_copy_out( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMbindc_seq_assocFtest_char_copy_in_copy_outEx"} : (!fir.box>>) -> (!fir.box>>, !fir.box>>) +! CHECK: %[[VAL_2:.*]] = arith.constant 100 : i32 +! CHECK: %[[VAL_3:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.box>>) -> (!fir.box>>, i1) +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]] = fir.shift %[[VAL_4]], %[[VAL_4]] : (index, index) -> !fir.shift<2> +! CHECK: %[[VAL_6:.*]] = fir.rebox %[[VAL_3]]#0(%[[VAL_5]]) : (!fir.box>>, !fir.shift<2>) -> !fir.box>> +! CHECK: %[[VAL_7:.*]]:3 = hlfir.associate %[[VAL_2]] {adapt.valuebyref} : (i32) -> (!fir.ref, !fir.ref, i1) +! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_7]]#1 {uniq_name = "_QMbindc_seq_assocFtakes_charEn"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_9]]#0 : !fir.ref +! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (i32) -> i64 +! CHECK: %[[VAL_12:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_13:.*]] = arith.subi %[[VAL_11]], %[[VAL_12]] : i64 +! CHECK: %[[VAL_14:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_15:.*]] = arith.addi %[[VAL_13]], %[[VAL_14]] : i64 +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i64) -> index +! CHECK: %[[VAL_17:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_18:.*]] = arith.cmpi sgt, %[[VAL_16]], %[[VAL_17]] : index +! CHECK: %[[VAL_19:.*]] = arith.select %[[VAL_18]], %[[VAL_16]], %[[VAL_17]] : index +! CHECK: %[[VAL_20:.*]] = fir.shape_shift %[[VAL_8]], %[[VAL_19]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_21:.*]] = fir.box_elesize %[[VAL_6]] : (!fir.box>>) -> index +! CHECK: %[[VAL_22:.*]] = fir.box_addr %[[VAL_6]] : (!fir.box>>) -> !fir.ref>> +! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (!fir.ref>>) -> !fir.ref>> +! CHECK: %[[VAL_24:.*]] = fir.embox %[[VAL_23]](%[[VAL_20]]) typeparams %[[VAL_21]] : (!fir.ref>>, !fir.shapeshift<1>, index) -> !fir.box>> +! CHECK: fir.call @takes_char(%[[VAL_24]], %[[VAL_7]]#1) fastmath : (!fir.box>>, !fir.ref) -> () +! CHECK: hlfir.copy_out %[[VAL_3]]#0, %[[VAL_3]]#1 to %[[VAL_1]]#0 : (!fir.box>>, i1, !fir.box>>) -> () +! CHECK: hlfir.end_associate %[[VAL_7]]#1, %[[VAL_7]]#2 : !fir.ref, i1 +! CHECK: return +! CHECK: } + + subroutine test_char_assumed_size(x) + character(*) :: x(:, :) + call takes_char_assumed_size(x) + end subroutine +! CHECK-LABEL: func.func @_QMbindc_seq_assocPtest_char_assumed_size( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMbindc_seq_assocFtest_char_assumed_sizeEx"} : (!fir.box>>) -> (!fir.box>>, !fir.box>>) +! CHECK: %[[VAL_2:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.box>>) -> (!fir.box>>, i1) +! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_4:.*]] = fir.shift %[[VAL_3]], %[[VAL_3]] : (index, index) -> !fir.shift<2> +! CHECK: %[[VAL_5:.*]] = fir.rebox %[[VAL_2]]#0(%[[VAL_4]]) : (!fir.box>>, !fir.shift<2>) -> !fir.box>> +! CHECK: %[[VAL_6:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i64 +! CHECK: %[[VAL_8:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_9:.*]] = arith.subi %[[VAL_7]], %[[VAL_8]] : i64 +! CHECK: %[[VAL_10:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_11:.*]] = arith.addi %[[VAL_9]], %[[VAL_10]] : i64 +! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index +! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_14:.*]] = arith.cmpi sgt, %[[VAL_12]], %[[VAL_13]] : index +! CHECK: %[[VAL_15:.*]] = arith.select %[[VAL_14]], %[[VAL_12]], %[[VAL_13]] : index +! CHECK: %[[VAL_16:.*]] = arith.constant -1 : i64 +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (i64) -> index +! CHECK: %[[VAL_18:.*]] = fir.shape_shift %[[VAL_6]], %[[VAL_15]], %[[VAL_6]], %[[VAL_17]] : (index, index, index, index) -> !fir.shapeshift<2> +! CHECK: %[[VAL_19:.*]] = fir.box_elesize %[[VAL_5]] : (!fir.box>>) -> index +! CHECK: %[[VAL_20:.*]] = fir.box_addr %[[VAL_5]] : (!fir.box>>) -> !fir.ref>> +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (!fir.ref>>) -> !fir.ref>> +! CHECK: %[[VAL_22:.*]] = fir.embox %[[VAL_21]](%[[VAL_18]]) typeparams %[[VAL_19]] : (!fir.ref>>, !fir.shapeshift<2>, index) -> !fir.box>> +! CHECK: fir.call @takes_char_assumed_size(%[[VAL_22]]) fastmath : (!fir.box>>) -> () +! CHECK: hlfir.copy_out %[[VAL_2]]#0, %[[VAL_2]]#1 to %[[VAL_1]]#0 : (!fir.box>>, i1, !fir.box>>) -> () +! CHECK: return +! CHECK: } + + subroutine test_optional_char(x) + character(*), optional :: x(10, 20) + call takes_optional_char(x, 100) + end subroutine +! CHECK-LABEL: func.func @_QMbindc_seq_assocPtest_optional_char( +! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_2:.*]](%[[VAL_5:.*]]) typeparams %[[VAL_1:.*]]#1 {fortran_attrs = #fir.var_attrs, uniq_name = "_QMbindc_seq_assocFtest_optional_charEx"} : (!fir.ref>>, !fir.shape<2>, index) -> (!fir.box>>, !fir.ref>>) +! CHECK: %[[VAL_7:.*]] = fir.is_present %[[VAL_6]]#0 : (!fir.box>>) -> i1 +! CHECK: %[[VAL_8:.*]] = arith.constant 100 : i32 +! CHECK: %[[VAL_9:.*]] = fir.if %[[VAL_7]] -> (!fir.box>>) { +! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_11:.*]] = fir.shift %[[VAL_10]], %[[VAL_10]] : (index, index) -> !fir.shift<2> +! CHECK: %[[VAL_12:.*]] = fir.rebox %[[VAL_6]]#0(%[[VAL_11]]) : (!fir.box>>, !fir.shift<2>) -> !fir.box>> +! CHECK: fir.result %[[VAL_12]] : !fir.box>> +! CHECK: } else { +! CHECK: %[[VAL_13:.*]] = fir.absent !fir.box>> +! CHECK: fir.result %[[VAL_13]] : !fir.box>> +! CHECK: } +! CHECK: %[[VAL_14:.*]]:3 = hlfir.associate %[[VAL_8]] {adapt.valuebyref} : (i32) -> (!fir.ref, !fir.ref, i1) +! CHECK: %[[VAL_15:.*]] = fir.if %[[VAL_7]] -> (!fir.box>>) { +! CHECK: %[[VAL_16:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_17:.*]]:2 = hlfir.declare %[[VAL_14]]#1 {uniq_name = "_QMbindc_seq_assocFtakes_optional_charEn"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_17]]#0 : !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> i64 +! CHECK: %[[VAL_20:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_21:.*]] = arith.subi %[[VAL_19]], %[[VAL_20]] : i64 +! CHECK: %[[VAL_22:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_23:.*]] = arith.addi %[[VAL_21]], %[[VAL_22]] : i64 +! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (i64) -> index +! CHECK: %[[VAL_25:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_26:.*]] = arith.cmpi sgt, %[[VAL_24]], %[[VAL_25]] : index +! CHECK: %[[VAL_27:.*]] = arith.select %[[VAL_26]], %[[VAL_24]], %[[VAL_25]] : index +! CHECK: %[[VAL_28:.*]] = fir.shape_shift %[[VAL_16]], %[[VAL_27]] : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_29:.*]] = fir.box_elesize %[[VAL_9]] : (!fir.box>>) -> index +! CHECK: %[[VAL_30:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box>>) -> !fir.ref>> +! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (!fir.ref>>) -> !fir.ref>> +! CHECK: %[[VAL_32:.*]] = fir.embox %[[VAL_31]](%[[VAL_28]]) typeparams %[[VAL_29]] : (!fir.ref>>, !fir.shapeshift<1>, index) -> !fir.box>> +! CHECK: fir.result %[[VAL_32]] : !fir.box>> +! CHECK: } else { +! CHECK: %[[VAL_33:.*]] = fir.absent !fir.box>> +! CHECK: fir.result %[[VAL_33]] : !fir.box>> +! CHECK: } +! CHECK: fir.call @takes_optional_char(%[[VAL_15]], %[[VAL_14]]#1) fastmath : (!fir.box>>, !fir.ref) -> () +! CHECK: hlfir.end_associate %[[VAL_14]]#1, %[[VAL_14]]#2 : !fir.ref, i1 +! CHECK: return +! CHECK: } +end module + +module poly_seq_assoc + interface + subroutine takes_poly(x, n) + integer :: n + class(*) :: x(n) + end subroutine + subroutine takes_poly_assumed_size(x) + class(*) :: x(10, *) + end subroutine + subroutine takes_optional_poly(x, n) + integer :: n + class(*), optional :: x(n) + end subroutine + end interface +contains + subroutine test_poly_1(x) + class(*) :: x(10, 20) + call takes_poly(x, 100) + end subroutine +! CHECK-LABEL: func.func @_QMpoly_seq_assocPtest_poly_1( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.class> {fir.bindc_name = "x"}) { +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMpoly_seq_assocFtest_poly_1Ex"} : (!fir.class>) -> (!fir.class>, !fir.class>) +! CHECK: %[[VAL_2:.*]] = arith.constant 100 : i32 +! CHECK: %[[VAL_3:.*]]:3 = hlfir.associate %[[VAL_2]] {adapt.valuebyref} : (i32) -> (!fir.ref, !fir.ref, i1) +! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]]#1 {uniq_name = "_QMpoly_seq_assocFtakes_polyEn"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]]#0 : !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> i64 +! CHECK: %[[VAL_7:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_8:.*]] = arith.subi %[[VAL_6]], %[[VAL_7]] : i64 +! CHECK: %[[VAL_9:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_10:.*]] = arith.addi %[[VAL_8]], %[[VAL_9]] : 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:.*]] = fir.shape %[[VAL_14]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_16:.*]] = fir.box_addr %[[VAL_1]]#1 : (!fir.class>) -> !fir.ref> +! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_18:.*]] = fir.embox %[[VAL_17]](%[[VAL_15]]) source_box %[[VAL_1]]#0 : (!fir.ref>, !fir.shape<1>, !fir.class>) -> !fir.class> +! CHECK: fir.call @_QPtakes_poly(%[[VAL_18]], %[[VAL_3]]#1) fastmath : (!fir.class>, !fir.ref) -> () +! CHECK: hlfir.end_associate %[[VAL_3]]#1, %[[VAL_3]]#2 : !fir.ref, i1 +! CHECK: return +! CHECK: } + + subroutine test_poly_copy_in_copy_out(x) + class(*) :: x(:, :) + call takes_poly(x, 100) + end subroutine +! CHECK-LABEL: func.func @_QMpoly_seq_assocPtest_poly_copy_in_copy_out( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMpoly_seq_assocFtest_poly_copy_in_copy_outEx"} : (!fir.class>) -> (!fir.class>, !fir.class>) +! CHECK: %[[VAL_2:.*]] = arith.constant 100 : i32 +! CHECK: %[[VAL_3:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.class>) -> (!fir.class>, i1) +! CHECK: %[[VAL_4:.*]]:3 = hlfir.associate %[[VAL_2]] {adapt.valuebyref} : (i32) -> (!fir.ref, !fir.ref, i1) +! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]]#1 {uniq_name = "_QMpoly_seq_assocFtakes_polyEn"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]]#0 : !fir.ref +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i32) -> i64 +! CHECK: %[[VAL_8:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_9:.*]] = arith.subi %[[VAL_7]], %[[VAL_8]] : i64 +! CHECK: %[[VAL_10:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_11:.*]] = arith.addi %[[VAL_9]], %[[VAL_10]] : i64 +! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index +! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_14:.*]] = arith.cmpi sgt, %[[VAL_12]], %[[VAL_13]] : index +! CHECK: %[[VAL_15:.*]] = arith.select %[[VAL_14]], %[[VAL_12]], %[[VAL_13]] : index +! CHECK: %[[VAL_16:.*]] = fir.shape %[[VAL_15]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_17:.*]] = fir.box_addr %[[VAL_3]]#0 : (!fir.class>) -> !fir.ref> +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_17]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_19:.*]] = fir.embox %[[VAL_18]](%[[VAL_16]]) source_box %[[VAL_3]]#0 : (!fir.ref>, !fir.shape<1>, !fir.class>) -> !fir.class> +! CHECK: fir.call @_QPtakes_poly(%[[VAL_19]], %[[VAL_4]]#1) fastmath : (!fir.class>, !fir.ref) -> () +! CHECK: hlfir.copy_out %[[VAL_3]]#0, %[[VAL_3]]#1 to %[[VAL_1]]#0 : (!fir.class>, i1, !fir.class>) -> () +! CHECK: hlfir.end_associate %[[VAL_4]]#1, %[[VAL_4]]#2 : !fir.ref, i1 +! CHECK: return +! CHECK: } + + subroutine test_poly_assumed_size(x) + class(*) :: x(:, :) + call takes_poly_assumed_size(x) + end subroutine +! CHECK-LABEL: func.func @_QMpoly_seq_assocPtest_poly_assumed_size( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMpoly_seq_assocFtest_poly_assumed_sizeEx"} : (!fir.class>) -> (!fir.class>, !fir.class>) +! CHECK: %[[VAL_2:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.class>) -> (!fir.class>, i1) +! CHECK: %[[VAL_3:.*]] = arith.constant 10 : i64 +! CHECK: %[[VAL_4:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_5:.*]] = arith.subi %[[VAL_3]], %[[VAL_4]] : i64 +! CHECK: %[[VAL_6:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_7:.*]] = arith.addi %[[VAL_5]], %[[VAL_6]] : i64 +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index +! CHECK: %[[VAL_9:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_10:.*]] = arith.cmpi sgt, %[[VAL_8]], %[[VAL_9]] : index +! CHECK: %[[VAL_11:.*]] = arith.select %[[VAL_10]], %[[VAL_8]], %[[VAL_9]] : index +! CHECK: %[[VAL_12:.*]] = arith.constant -1 : i64 +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (i64) -> index +! CHECK: %[[VAL_14:.*]] = fir.shape %[[VAL_11]], %[[VAL_13]] : (index, index) -> !fir.shape<2> +! CHECK: %[[VAL_15:.*]] = fir.box_addr %[[VAL_2]]#0 : (!fir.class>) -> !fir.ref> +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_17:.*]] = fir.embox %[[VAL_16]](%[[VAL_14]]) source_box %[[VAL_2]]#0 : (!fir.ref>, !fir.shape<2>, !fir.class>) -> !fir.class> +! CHECK: fir.call @_QPtakes_poly_assumed_size(%[[VAL_17]]) fastmath : (!fir.class>) -> () +! CHECK: hlfir.copy_out %[[VAL_2]]#0, %[[VAL_2]]#1 to %[[VAL_1]]#0 : (!fir.class>, i1, !fir.class>) -> () +! CHECK: return +! CHECK: } + + subroutine test_optional_poly(x) + class(*), optional :: x(10, 20) + call takes_optional_poly(x, 100) + end subroutine +! CHECK-LABEL: func.func @_QMpoly_seq_assocPtest_optional_poly( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QMpoly_seq_assocFtest_optional_polyEx"} : (!fir.class>) -> (!fir.class>, !fir.class>) +! CHECK: %[[VAL_2:.*]] = fir.is_present %[[VAL_1]]#0 : (!fir.class>) -> i1 +! CHECK: %[[VAL_3:.*]] = arith.constant 100 : i32 +! CHECK: %[[VAL_4:.*]] = fir.if %[[VAL_2]] -> (!fir.class>) { +! CHECK: fir.result %[[VAL_1]]#0 : !fir.class> +! CHECK: } else { +! CHECK: %[[VAL_5:.*]] = fir.absent !fir.class> +! CHECK: fir.result %[[VAL_5]] : !fir.class> +! CHECK: } +! CHECK: %[[VAL_6:.*]]:3 = hlfir.associate %[[VAL_3]] {adapt.valuebyref} : (i32) -> (!fir.ref, !fir.ref, i1) +! CHECK: %[[VAL_7:.*]] = fir.if %[[VAL_2]] -> (!fir.class>) { +! CHECK: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_6]]#1 {uniq_name = "_QMpoly_seq_assocFtakes_optional_polyEn"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_8]]#0 : !fir.ref +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> i64 +! CHECK: %[[VAL_11:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_12:.*]] = arith.subi %[[VAL_10]], %[[VAL_11]] : i64 +! CHECK: %[[VAL_13:.*]] = arith.constant 1 : i64 +! CHECK: %[[VAL_14:.*]] = arith.addi %[[VAL_12]], %[[VAL_13]] : 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:.*]] = fir.shape %[[VAL_18]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_20:.*]] = fir.box_addr %[[VAL_4]] : (!fir.class>) -> !fir.ref> +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_22:.*]] = fir.embox %[[VAL_21]](%[[VAL_19]]) source_box %[[VAL_4]] : (!fir.ref>, !fir.shape<1>, !fir.class>) -> !fir.class> +! CHECK: fir.result %[[VAL_22]] : !fir.class> +! CHECK: } else { +! CHECK: %[[VAL_23:.*]] = fir.absent !fir.class> +! CHECK: fir.result %[[VAL_23]] : !fir.class> +! CHECK: } +! CHECK: fir.call @_QPtakes_optional_poly(%[[VAL_7]], %[[VAL_6]]#1) fastmath : (!fir.class>, !fir.ref) -> () +! CHECK: hlfir.end_associate %[[VAL_6]]#1, %[[VAL_6]]#2 : !fir.ref, i1 +! CHECK: return +! CHECK: } +end module