diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -92,6 +92,10 @@ non-global name in the same scope. This is not conforming, but it is useful and unambiguous. * The argument to `RANDOM_NUMBER` may not be an assumed-size array. +* Note 1 in 8.5.3 prohibits using the result of referencing a function whose + result variable has the ALLOCATABLE attribute as an allocatable actual + argument. + As other compilers accept this, so does f18, with a portability warning. ## Extensions, deletions, and legacy features supported by default diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -198,6 +198,7 @@ std::string GetName() const; std::optional GetType() const; + const Symbol *GetResult() const; int Rank() const; bool IsElemental() const; bool IsPure() const; @@ -228,6 +229,7 @@ int Rank() const; bool IsElemental() const { return proc_.IsElemental(); } bool hasAlternateReturns() const { return hasAlternateReturns_; } + const Symbol *GetResult() const { return proc_.GetResult(); } Expr *UnwrapArgExpr(int n) { if (static_cast(n) < arguments_.size() && arguments_[n]) { diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -978,6 +978,8 @@ bool IsNullPointer(const Expr &); bool IsObjectPointer(const Expr &, FoldingContext &); +bool IsFunctionRef(const Expr &); + // Can Expr be passed as absent to an optional dummy argument. // See 15.5.2.12 point 1 for more details. bool MayBePassedAsAbsentOptional(const Expr &, FoldingContext &); diff --git a/flang/lib/Evaluate/call.cpp b/flang/lib/Evaluate/call.cpp --- a/flang/lib/Evaluate/call.cpp +++ b/flang/lib/Evaluate/call.cpp @@ -98,6 +98,18 @@ return std::nullopt; } +const Symbol *ProcedureDesignator::GetResult() const { + if (const Symbol * procSym{GetSymbol()}) { + if (const auto *subprogram{ + std::get_if(&procSym->details())}) { + if (subprogram->isFunction()) { + return &subprogram->result(); + } + } + } + return nullptr; +} + int ProcedureDesignator::Rank() const { if (const Symbol * symbol{GetSymbol()}) { // Subtle: will be zero for functions returning procedure pointers diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2794,15 +2794,20 @@ const std::string &name{call.specificIntrinsic.name}; if (name == "allocated") { const auto &arg{call.arguments[0]}; + bool funcRef{false}; if (arg) { if (const auto *expr{arg->UnwrapExpr()}) { ok = evaluate::IsAllocatableDesignator(*expr); + funcRef = evaluate::IsFunctionRef(*expr); } } if (!ok) { context.messages().Say( arg ? arg->sourceLocation() : context.messages().at(), "Argument of ALLOCATED() must be an ALLOCATABLE object or component"_err_en_US); + } else if (funcRef) { + context.messages().Say( + "Argument of ALLOCATED() must be an ALLOCATABLE variable"_err_en_US); } } else if (name == "associated") { // Now handled in Semantics/check-call.cpp diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -740,6 +740,13 @@ return designator && designator->GetType().has_value(); } +bool IsFunctionRef(const Expr &expr) { + if (const ProcedureRef * proc{GetProcedureRef(expr)}) { + return proc->GetResult() != nullptr; + } + return false; +} + bool IsProcedurePointer(const Expr &expr) { return common::visit(common::visitors{ [](const NullPointer &) { return true; }, @@ -1155,20 +1162,30 @@ return std::nullopt; } +static const semantics::Symbol *GetFunctionResult(const Expr &expr) { + if (const ProcedureRef * proc{GetProcedureRef(expr)}) { + return proc->GetResult(); + } + return nullptr; +} + bool IsAllocatableOrPointerObject( const Expr &expr, FoldingContext &context) { const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentDataRef(expr)}; + if (!sym) { + sym = GetFunctionResult(expr); + } return (sym && semantics::IsAllocatableOrPointer(*sym)) || evaluate::IsObjectPointer(expr, context); } bool IsAllocatableDesignator(const Expr &expr) { // Allocatable sub-objects are not themselves allocatable (9.5.3.1 NOTE 2). - if (const semantics::Symbol * - sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}) { - return semantics::IsAllocatable(sym->GetUltimate()); + const semantics::Symbol *sym{UnwrapWholeSymbolOrComponentOrCoarrayRef(expr)}; + if (!sym) { + sym = GetFunctionResult(expr); } - return false; + return sym && semantics::IsAllocatable(sym->GetUltimate()); } bool MayBePassedAsAbsentOptional( diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp --- a/flang/lib/Semantics/check-call.cpp +++ b/flang/lib/Semantics/check-call.cpp @@ -478,6 +478,11 @@ "ALLOCATABLE %s must be associated with an ALLOCATABLE actual argument"_err_en_US, dummyName); } + if (actualIsAllocatable && IsFunctionRef(actual)) { + messages.Say( + "Function reference associated with ALLOCATABLE %s"_port_en_US, + dummyName); + } if (actualIsAllocatable && actualIsCoindexed && dummy.intent != common::Intent::In) { messages.Say( diff --git a/flang/test/Lower/allocatable-result.f90 b/flang/test/Lower/allocatable-result.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/allocatable-result.f90 @@ -0,0 +1,90 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test the use of allocatable function results as allocatable arguments. + +!CHECK-LABEL: func @_QPtest() { +subroutine test() + integer, allocatable, dimension(:) :: x + interface + function f(x) + integer, allocatable, dimension(:) :: f, x + end function + end interface + +!CHECK: %[[T0_ADDR:.*]] = fir.alloca !fir.box>> +!CHECK: %[[T1_ADDR:.*]] = fir.alloca !fir.box>> +!CHECK: %[[X_ADDR:.*]] = fir.alloca !fir.box>> +!CHECK: %[[X_ARR_ADDR:.*]] = fir.alloca !fir.heap> +!CHECK: %[[X_LB_ADDR:.*]] = fir.alloca index +!CHECK: %[[X_EXT_ADDR:.*]] = fir.alloca index +!CHECK: %[[ZERO_ARR_HEAP:.*]] = fir.zero_bits !fir.heap> +!CHECK: fir.store %[[ZERO_ARR_HEAP]] to %[[X_ARR_ADDR]] : !fir.ref>> +!CHECK: %[[X_LB:.*]] = fir.load %[[X_LB_ADDR]] : !fir.ref +!CHECK: %[[X_EXT:.*]] = fir.load %[[X_EXT_ADDR]] : !fir.ref +!CHECK: %[[X_ARR_HEAP:.*]] = fir.load %[[X_ARR_ADDR]] : !fir.ref>> +!CHECK: %[[X_SHAPE:.*]] = fir.shape_shift %[[X_LB]], %[[X_EXT]] : (index, index) -> !fir.shapeshift<1> +!CHECK: %[[X_BOX:.*]] = fir.embox %[[X_ARR_HEAP]](%[[X_SHAPE]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.box>> +!CHECK: fir.store %[[X_BOX]] to %[[X_ADDR]] : !fir.ref>>> +! Call f(x) +!CHECK: %[[F0:.*]] = fir.call @_QPf(%[[X_ADDR]]){{.*}} : (!fir.ref>>>) -> !fir.box>> +!CHECK: fir.save_result %[[F0]] to %[[T1_ADDR]] : !fir.box>>, !fir.ref>>> +!CHECK: %[[X_BOX:.*]] = fir.load %[[X_ADDR]] : !fir.ref>>> +!CHECK: %[[ZERO:.*]] = arith.constant 0 : index +!CHECK: %[[X_DIMS:.*]]:3 = fir.box_dims %[[X_BOX]], %[[ZERO]] : (!fir.box>>, index) -> (index, index, index) +!CHECK: %[[X_ARR_HEAP:.*]] = fir.box_addr %[[X_BOX]] : (!fir.box>>) -> !fir.heap> +!CHECK: fir.store %[[X_ARR_HEAP]] to %[[X_ARR_ADDR]] : !fir.ref>> +!CHECK: fir.store %[[X_DIMS]]#1 to %[[X_EXT_ADDR]] : !fir.ref +!CHECK: fir.store %[[X_DIMS]]#0 to %[[X_LB_ADDR]] : !fir.ref +! Call f(f(x)) +!CHECK: %[[F1:.*]] = fir.call @_QPf(%[[T1_ADDR]]){{.*}} : (!fir.ref>>>) -> !fir.box>> +!CHECK: fir.save_result %[[F1]] to %[[T0_ADDR]] : !fir.box>>, !fir.ref>>> +!CHECK: %[[T0_BOX:.*]] = fir.load %[[T0_ADDR]] : !fir.ref>>> +!CHECK: %[[ZERO:.*]] = arith.constant 0 : index +!CHECK: %[[T0_DIMS:.*]]:3 = fir.box_dims %[[T0_BOX]], %[[ZERO]] : (!fir.box>>, index) -> (index, index, index) +!CHECK: %[[T0_ARR_HEAP:.*]] = fir.box_addr %[[T0_BOX]] : (!fir.box>>) -> !fir.heap> +!CHECK: %[[T0_SHAPE:.*]] = fir.shape_shift %[[T0_DIMS]]#0, %[[T0_DIMS]]#1 : (index, index) -> !fir.shapeshift<1> +!CHECK: %[[T0_ARR:.*]] = fir.array_load %[[T0_ARR_HEAP]](%[[T0_SHAPE]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.array +! Check if X is allocated +!CHECK: %[[X_ARR_HEAP:.*]] = fir.load %[[X_ARR_ADDR]] : !fir.ref>> +!CHECK: %[[X_ARR_HEAP_AS_INT:.*]] = fir.convert %[[X_ARR_HEAP]] : (!fir.heap>) -> i64 +!CHECK: %[[ZERO:.*]] = arith.constant 0 : i64 +!CHECK: %[[X_ALLOCATED:.*]] = arith.cmpi ne, %[[X_ARR_HEAP_AS_INT]], %[[ZERO]] : i64 +!CHECK: %[[RES_NOT_X_AND_RES_ARR_HEAP:.*]]:2 = fir.if %[[X_ALLOCATED]] -> (i1, !fir.heap>) { +! Skip if-else contents, that copies T0 to X or to a new temporary, that +! later replaces X. +!CHECK: } +! Update X, if needed +!CHECK: fir.if %[[RES_NOT_X_AND_RES_ARR_HEAP]]#0 { +!CHECK: fir.if %[[X_ALLOCATED]] { +!CHECK: fir.freemem %[[X_ARR_HEAP]] : !fir.heap> +!CHECK: } +!CHECK: fir.store %[[RES_NOT_X_AND_RES_ARR_HEAP]]#1 to %[[X_ARR_ADDR]] : !fir.ref>> +!CHECK: fir.store %[[T0_DIMS]]#1 to %[[X_EXT_ADDR]] : !fir.ref +!CHECK: %[[ONE:.*]] = arith.constant 1 : index +!CHECK: fir.store %[[ONE]] to %[[X_LB_ADDR]] : !fir.ref +!CHECK: } +! Deallocate T0 +!CHECK: %[[T0_BOX:.*]] = fir.load %[[T0_ADDR]] : !fir.ref>>> +!CHECK: %[[T0_ARR_HEAP:.*]] = fir.box_addr %[[T0_BOX]] : (!fir.box>>) -> !fir.heap> +!CHECK: %[[T0_ARR_HEAP_AS_INT:.*]] = fir.convert %[[T0_ARR_HEAP]] : (!fir.heap>) -> i64 +!CHECK: %[[ZERO:.*]] = arith.constant 0 : i64 +!CHECK: %[[T0_ARR_HEAP_ALLOCATED:.*]] = arith.cmpi ne, %[[T0_ARR_HEAP_AS_INT]], %[[ZERO]] : i64 +!CHECK: fir.if %[[T0_ARR_HEAP_ALLOCATED]] { +!CHECK: fir.freemem %[[T0_ARR_HEAP]] : !fir.heap> +!CHECK: } +! Deallocate T1 +!CHECK: %[[T1_BOX:.*]] = fir.load %[[T1_ADDR]] : !fir.ref>>> +!CHECK: %[[T1_ARR_HEAP:.*]] = fir.box_addr %[[T1_BOX]] : (!fir.box>>) -> !fir.heap> +!CHECK: %[[T1_ARR_HEAP_AS_INT:.*]] = fir.convert %[[T1_ARR_HEAP]] : (!fir.heap>) -> i64 +!CHECK: %[[ZERO:.*]] = arith.constant 0 : i64 +!CHECK: %[[T1_ARR_HEAP_ALLOCATED:.*]] = arith.cmpi ne, %[[T1_ARR_HEAP_AS_INT]], %[[ZERO]] : i64 +!CHECK: fir.if %[[T1_ARR_HEAP_ALLOCATED]] { +!CHECK: fir.freemem %[[T1_ARR_HEAP]] : !fir.heap> +!CHECK: } +!CHECK: return +!CHECK: } + + x = f(f(x)) +end subroutine + +!CHECK: func private @_QPf(!fir.ref>>>) -> !fir.box>> diff --git a/flang/test/Semantics/allocated.f90 b/flang/test/Semantics/allocated.f90 --- a/flang/test/Semantics/allocated.f90 +++ b/flang/test/Semantics/allocated.f90 @@ -61,6 +61,6 @@ print *, allocated(t2_not_alloc%coarray_alloc_array(1)) !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component print *, allocated(t2_not_alloc%coarray_alloc_array(1)[2]) - !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE object or component + !ERROR: Argument of ALLOCATED() must be an ALLOCATABLE variable print *, allocated(return_allocatable()) end subroutine diff --git a/flang/test/Semantics/call06.f90 b/flang/test/Semantics/call06.f90 --- a/flang/test/Semantics/call06.f90 +++ b/flang/test/Semantics/call06.f90 @@ -37,8 +37,8 @@ call s01(scalar) !ERROR: ALLOCATABLE dummy argument 'x=' must be associated with an ALLOCATABLE actual argument call s01(1.) - !ERROR: ALLOCATABLE dummy argument 'x=' must be associated with an ALLOCATABLE actual argument - call s01(allofunc()) ! subtle: ALLOCATABLE function result isn't + !PORTABILITY: Function reference associated with ALLOCATABLE dummy argument 'x=' + call s01(allofunc()) call s02(cov) ! ok call s03(com) ! ok !ERROR: ALLOCATABLE dummy argument 'x=' has corank 1 but actual argument has corank 2