diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -2093,6 +2093,8 @@ fir::ExtendedValue genAssociateSelector(const Fortran::lower::SomeExpr &selector, Fortran::lower::StatementContext &stmtCtx) { + if (lowerToHighLevelFIR()) + return genExprAddr(selector, stmtCtx); return Fortran::lower::isArraySectionWithoutVectorSubscript(selector) ? Fortran::lower::createSomeArrayBox(*this, selector, localSymbols, stmtCtx) diff --git a/flang/lib/Lower/Mangler.cpp b/flang/lib/Lower/Mangler.cpp --- a/flang/lib/Lower/Mangler.cpp +++ b/flang/lib/Lower/Mangler.cpp @@ -41,12 +41,20 @@ static std::optional hostName(const Fortran::semantics::Symbol &symbol) { - const Fortran::semantics::Scope &scope = symbol.owner(); - if (scope.kind() == Fortran::semantics::Scope::Kind::Subprogram) { - assert(scope.symbol() && "subprogram scope must have a symbol"); - return toStringRef(scope.symbol()->name()); + const Fortran::semantics::Scope *scope = &symbol.owner(); + if (symbol.has()) + // Associate/Select construct scopes are not part of the mangling. This can + // result in different construct selector being mangled with the same name. + // This is not an issue since these are not global symbols. + while (!scope->IsTopLevel() && + (scope->kind() != Fortran::semantics::Scope::Kind::Subprogram && + scope->kind() != Fortran::semantics::Scope::Kind::MainProgram)) + scope = &scope->parent(); + if (scope->kind() == Fortran::semantics::Scope::Kind::Subprogram) { + assert(scope->symbol() && "subprogram scope must have a symbol"); + return toStringRef(scope->symbol()->name()); } - if (scope.kind() == Fortran::semantics::Scope::Kind::MainProgram) + if (scope->kind() == Fortran::semantics::Scope::Kind::MainProgram) // Do not use the main program name, if any, because it may lead to name // collision with procedures with the same name in other compilation units // (technically illegal, but all compilers are able to compile and link @@ -80,6 +88,15 @@ Fortran::semantics::ProcedureDefinitionClass::Internal) return ultimateSymbol.name().ToString(); + // mangle ObjectEntityDetails or AssocEntityDetails symbols. + auto mangleObject = [&]() -> std::string { + llvm::SmallVector modNames = moduleNames(ultimateSymbol); + std::optional optHost = hostName(ultimateSymbol); + if (Fortran::semantics::IsNamedConstant(ultimateSymbol)) + return fir::NameUniquer::doConstant(modNames, optHost, symbolName); + return fir::NameUniquer::doVariable(modNames, optHost, symbolName); + }; + return std::visit( Fortran::common::visitors{ [&](const Fortran::semantics::MainProgramDetails &) { @@ -117,13 +134,10 @@ symbolName); }, [&](const Fortran::semantics::ObjectEntityDetails &) { - llvm::SmallVector modNames = - moduleNames(ultimateSymbol); - std::optional optHost = hostName(ultimateSymbol); - if (Fortran::semantics::IsNamedConstant(ultimateSymbol)) - return fir::NameUniquer::doConstant(modNames, optHost, - symbolName); - return fir::NameUniquer::doVariable(modNames, optHost, symbolName); + return mangleObject(); + }, + [&](const Fortran::semantics::AssocEntityDetails &) { + return mangleObject(); }, [&](const Fortran::semantics::NamelistDetails &) { llvm::SmallVector modNames = diff --git a/flang/test/Lower/HLFIR/associate-construct.f90 b/flang/test/Lower/HLFIR/associate-construct.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/HLFIR/associate-construct.f90 @@ -0,0 +1,97 @@ +! Test lowering of associate construct to HLFIR +! RUN: bbc -emit-fir -hlfir -o - %s | FileCheck %s + +subroutine associate_expr(x) + integer :: x(:) + associate(y => x + 42) + print *, y + end associate +end subroutine +! CHECK-LABEL: func.func @_QPassociate_expr( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex" +! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_4:.*]]:3 = fir.box_dims %[[VAL_1]]#0, %[[VAL_3]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_6:.*]] = hlfir.elemental {{.*}} +! CHECK: %[[VAL_11:.*]]:3 = hlfir.associate %[[VAL_6]]{{.*}} +! CHECK: %[[VAL_13:.*]] = fir.shape %[[VAL_4]]#1 : (index) -> !fir.shape<1> +! CHECK: %[[VAL_14:.*]]:2 = hlfir.declare %[[VAL_11]]#1(%[[VAL_13]]) {uniq_name = "_QFassociate_exprEy"} : (!fir.ref>, !fir.shape<1>) -> (!fir.box>, !fir.ref>) +! CHECK: fir.call @_FortranAioEndIoStatement +! CHECK: hlfir.end_associate %[[VAL_11]]#1, %[[VAL_11]]#2 : !fir.ref>, i1 + +subroutine associate_var(x) + integer :: x + associate(y => x) + print *, y + end associate +end subroutine +! CHECK-LABEL: func.func @_QPassociate_var( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex" +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]]#1 {uniq_name = "_QFassociate_varEy"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: fir.call @_FortranAioEndIoStatement +! CHECK-NEXT: return + +subroutine associate_pointer(x) + integer, pointer, contiguous :: x(:) + ! Check that "y" has the target and contiguous attributes. + associate(y => x) + print *, y + end associate +end subroutine +! CHECK-LABEL: func.func @_QPassociate_pointer( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex" +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box>>) -> !fir.ptr> +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_4]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_6:.*]] = fir.shape_shift %[[VAL_5]]#0, %[[VAL_5]]#1 : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_3]](%[[VAL_6]]) {fortran_attrs = #fir.var_attrs, uniq_name = "_QFassociate_pointerEy"} : (!fir.ptr>, !fir.shapeshift<1>) -> (!fir.box>, !fir.ptr>) +! CHECK: fir.call @_FortranAioEndIoStatement +! CHECK-NEXT: return + +subroutine associate_allocatable(x) + integer, allocatable :: x(:) + associate(y => x) + print *, y + end associate +end subroutine +! CHECK-LABEL: func.func @_QPassociate_allocatable( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex" +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box>>) -> !fir.heap> +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_2]], %[[VAL_4]] : (!fir.box>>, index) -> (index, index, index) +! CHECK: %[[VAL_6:.*]] = fir.shape_shift %[[VAL_5]]#0, %[[VAL_5]]#1 : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_3]](%[[VAL_6]]) {uniq_name = "_QFassociate_allocatableEy"} : (!fir.heap>, !fir.shapeshift<1>) -> (!fir.box>, !fir.heap>) +! CHECK: fir.call @_FortranAioEndIoStatement +! CHECK-NEXT: return + +subroutine associate_optional(x) + integer, optional :: x(:) + ! Check that "y" is not given the optional attribute: x must be present as per + ! Fortran 2018 11.1.3.2 point 4. + associate(y => x) + print *, y + end associate +end subroutine +! CHECK-LABEL: func.func @_QPassociate_optional( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex" +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_1]]#1 {uniq_name = "_QFassociate_optionalEy"} : (!fir.box>) -> (!fir.box>, !fir.box>) +! CHECK: fir.call @_FortranAioEndIoStatement +! CHECK-NEXT: return + +subroutine associate_pointer_section(x) + integer , pointer, contiguous :: x(:) + associate (y => x(1:20:1)) + print *, y + end associate +end subroutine +! CHECK-LABEL: func.func @_QPassociate_pointer_section( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex" +! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref>>> +! CHECK: %[[VAL_4:.*]] = arith.constant 20 : index +! CHECK: %[[VAL_6:.*]] = arith.constant 20 : index +! CHECK: %[[VAL_8:.*]] = hlfir.designate %[[VAL_2]]{{.*}} +! CHECK: %[[VAL_9:.*]] = fir.shape %[[VAL_6]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_10:.*]]:2 = hlfir.declare %[[VAL_8]](%[[VAL_9]]) {fortran_attrs = #fir.var_attrs, uniq_name = "_QFassociate_pointer_sectionEy"} : (!fir.ref>, !fir.shape<1>) -> (!fir.ref>, !fir.ref>) +! CHECK: fir.call @_FortranAioEndIoStatement +! CHECK-NEXT: return