https://gcc.gnu.org/g:eb6649a97d7a75b08d6c963ce99ddad9654b3aa9
commit r17-5522-geb6649a97d7a75b08d6c963ce99ddad9654b3aa9 Author: Jerry DeLisle <[email protected]> Date: Sun Oct 4 16:21:46 2026 -0700 fortran: [PR127731] Index pointer function results by their span A pointer array function can return a descriptor whose span is larger than the element size, for instance when the result points to a component of a derived-type array or to the real part of a complex array. Callers ignored that span: the result temporary was indexed by the element size, an associate name or pointer associated with the result was not marked as a subreference array pointer, and an actual argument was passed on without being packed. The patch marks the result temporary GFC_DECL_PTR_ARRAY_P, sets subref_array_pointer on the associate name and on the pointer object, and passes a pointer result to a non-pointer dummy through gfc_conv_subref_array_arg, which makes a packed copy when the span differs from the element size. Assisted-by: Claude Opus 5.5 PR fortran/127731 gcc/fortran/ChangeLog: * expr.cc (gfc_check_pointer_assign): Set subref_array_pointer on the pointer object when the target is a pointer array function result. * resolve.cc (resolve_assoc_var): Likewise on the associate name when the selector is a pointer array function result. * trans-expr.cc (pointer_array_result_p): New function. (pointer_result_var): New function. (gfc_conv_procedure_call): Pass a pointer array function result to a non-pointer dummy through gfc_conv_subref_array_arg. Mark the temporary for a pointer array result GFC_DECL_PTR_ARRAY_P. gcc/testsuite/ChangeLog: * gfortran.dg/pointer_function_span_1.f90: New test. * gfortran.dg/pointer_function_span_2.f90: New test. Diff: --- gcc/fortran/expr.cc | 5 + gcc/fortran/resolve.cc | 7 + gcc/fortran/trans-expr.cc | 77 +++++++++ .../gfortran.dg/pointer_function_span_1.f90 | 72 +++++++++ .../gfortran.dg/pointer_function_span_2.f90 | 180 +++++++++++++++++++++ 5 files changed, 341 insertions(+) diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 9e06866ad630..681808cd569e 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -4750,6 +4750,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue, attr = gfc_expr_attr (rvalue); + /* The elements of a pointer function result may be spaced by more than + the element size. */ + if (rvalue->expr_type == EXPR_FUNCTION && rvalue->rank > 0 && attr.pointer) + lvalue->symtree->n.sym->attr.subref_array_pointer = 1; + if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer) { /* F2008, C725. For PURE also C1283. Sometimes rvalue is a function call diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index d2ee82071189..f85a84d68e67 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -10786,6 +10786,13 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } + /* The elements of a pointer function result may be spaced by more than + the element size. */ + if (target->expr_type == EXPR_FUNCTION + && target->rank > 0 + && gfc_expr_attr (target).pointer) + sym->attr.subref_array_pointer = 1; + if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target)) { /* By now, the type of the target has been fixed up. */ diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 1bdf554d8f62..a2903eeeba1f 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7151,6 +7151,58 @@ copy_in_out_allowed (gfc_symbol *fsym, gfc_expr *e, bool nodesc_arg) } +/* Return true if E is a reference to a function returning a pointer array, + whose elements may be spaced by more than the element size. */ + +static bool +pointer_array_result_p (gfc_expr *e) +{ + return e->expr_type == EXPR_FUNCTION + && e->rank > 0 + && e->ts.type != BT_CLASS + && gfc_expr_attr (e).pointer; +} + + +/* Evaluate the pointer array function reference E into a temporary pointer + in BLOCK and return a variable expression for that pointer. */ + +static gfc_expr * +pointer_result_var (stmtblock_t *block, gfc_expr *e) +{ + gfc_symtree *st = gfc_get_unique_symtree (NULL); + gfc_symbol *sym = gfc_new_symbol (st->name, NULL); + st->n.sym = sym; + sym->ts = e->ts; + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.dimension = 1; + sym->attr.pointer = 1; + sym->as = gfc_get_array_spec (); + sym->as->rank = e->rank; + sym->as->type = AS_DEFERRED; + + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr_descriptor (&se, e); + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (block, &se.post); + + gcc_assert (VAR_P (se.expr) && GFC_DECL_PTR_ARRAY_P (se.expr)); + sym->backend_decl = se.expr; + + if (sym->ts.type == BT_CHARACTER) + { + sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + sym->ts.u.cl->backend_decl = gfc_evaluate_now (se.string_length, block); + } + + gfc_expr *var = gfc_get_variable_expr (st); + var->where = e->where; + return var; +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -8203,6 +8255,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, ? e->symtree->n.sym : NULL, false, true); + else if (pointer_array_result_p (e) + && !(fsym && fsym->attr.pointer) + && copy_in_out_allowed (fsym, e, nodesc_arg)) + /* A pointer function result is copied into a temporary when + its elements are not spaced by the element size. */ + { + gfc_expr *var = pointer_result_var (&parmse.pre, e); + gfc_conv_subref_array_arg (&parmse, var, nodesc_arg, + fsym ? fsym->attr.intent : INTENT_INOUT, + false, fsym, sym->name, NULL, true, false, + dummy_accepts_strided_arg (fsym, nodesc_arg)); + gfc_symtree *st = var->symtree; + gfc_free_expr (var); + gfc_free_symbol (st->n.sym); + XDELETE (st); + } + else if (e->expr_type == EXPR_VARIABLE && is_subref_array (e) && !(fsym && fsym->attr.pointer) @@ -9027,6 +9096,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, !comp->attr.pointer, callee_alloc, &se->ss->info->expr->where); + /* Index a pointer result by the span the callee returns. */ + if (comp->attr.pointer && VAR_P (info->descriptor)) + GFC_DECL_PTR_ARRAY_P (info->descriptor) = 1; + /* Pass the temporary as the first argument. */ result = info->descriptor; tmp = gfc_build_addr_expr (NULL_TREE, result); @@ -9063,6 +9136,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, !sym->attr.pointer, callee_alloc, &se->ss->info->expr->where); + /* Index a pointer result by the span the callee returns. */ + if (sym->attr.pointer && VAR_P (info->descriptor)) + GFC_DECL_PTR_ARRAY_P (info->descriptor) = 1; + /* Pass the temporary as the first argument. */ result = info->descriptor; tmp = gfc_build_addr_expr (NULL_TREE, result); diff --git a/gcc/testsuite/gfortran.dg/pointer_function_span_1.f90 b/gcc/testsuite/gfortran.dg/pointer_function_span_1.f90 new file mode 100644 index 000000000000..75e399df402d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_function_span_1.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! PR 127731 +! A pointer array function result used as a value is indexed by its span. + +program p + implicit none + type t + real :: x, y + end type + complex, target :: z(3) = [(1., 2.), (3., 4.), (5., 6.)] + type(t), target :: d(3) = [t(1., 2.), t(3., 4.), t(5., 6.)] + real, pointer :: r(:) + class(*), pointer :: q(:) + + if (any (g() /= [2., 4., 6.])) stop 1 + if (sum (g()) /= 12.) stop 2 + if (any (gd() /= [2., 4., 6.])) stop 3 + if (any (gr() /= [1., 3., 5.])) stop 4 + + associate (a => g()) + if (any (a /= [2., 4., 6.])) stop 5 + end associate + + call show (g(), 6) + + q => f() + select type (q) + type is (real) + if (any (q /= [2., 4., 6.])) stop 7 + class default + stop 8 + end select + + select type (s => f()) + type is (real) + if (any (s /= [2., 4., 6.])) stop 9 + class default + stop 10 + end select + + r => g() + if (any (r /= [2., 4., 6.])) stop 11 + +contains + + function g() result(res) + real, pointer :: res(:) + res => z%im + end function + + function gr() result(res) + real, pointer :: res(:) + res => z%re + end function + + function gd() result(res) + real, pointer :: res(:) + res => d%y + end function + + function f() result(res) + class(*), pointer :: res(:) + res => z%im + end function + + subroutine show (a, n) + real, intent(in) :: a(:) + integer, intent(in) :: n + if (any (a /= [2., 4., 6.])) stop n + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/pointer_function_span_2.f90 b/gcc/testsuite/gfortran.dg/pointer_function_span_2.f90 new file mode 100644 index 000000000000..3f298e65b065 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_function_span_2.f90 @@ -0,0 +1,180 @@ +! { dg-do run } +! PR 127731 +! Pointer array function results with a span other than the element size, +! passed as actual arguments to various dummies and defined through. + +module m + implicit none + type inner + integer :: a + real(8) :: b + end type + type t + character(3) :: s + integer :: i + real(8) :: d + logical :: l + type(inner) :: in + end type + type(t), target :: ta(4) + complex, target :: z2(2,3) +contains + function gi() result(res) + integer, pointer :: res(:) + res => ta%i + end function + function gd() result(res) + real(8), pointer :: res(:) + res => ta%d + end function + function gl() result(res) + logical, pointer :: res(:) + res => ta%l + end function + function gin() result(res) + type(inner), pointer :: res(:) + res => ta%in + end function + function gs() result(res) + character(3), pointer :: res(:) + res => ta%s + end function + function gsn(m) result(res) + integer :: m + character(m), pointer :: res(:) + res => ta%s + end function + function gsd() result(res) + character(:), pointer :: res(:) + res => ta%s + end function + function gsub() result(res) + character(2), pointer :: res(:) + res => ta%s(2:3) + end function + function g2() result(res) + real, pointer :: res(:,:) + res => z2%im + end function + integer function s_as (a) + integer, intent(in) :: a(:) + s_as = sum (a) + end function + integer function s_ex (a, n) + integer, intent(in) :: n, a(n) + s_ex = sum (a) + end function + integer function s_sz (a, n) + integer, intent(in) :: n, a(*) + s_sz = sum (a(1:n)) + end function + integer function s_ct (a) + integer, contiguous, intent(in) :: a(:) + s_ct = sum (a) + end function + integer function s_tg (a) + integer, target, intent(in) :: a(:) + s_tg = sum (a) + end function + integer function s_pt (a) + integer, pointer, intent(in) :: a(:) + s_pt = sum (a) + end function + real(8) function s_in (a) + type(inner), intent(in) :: a(:) + s_in = sum (a%a) + sum (a%b) + end function + integer function cnt (a) + logical, intent(in) :: a(:) + cnt = count (a) + end function + real function s2 (a) + real, intent(in) :: a(:,:) + s2 = sum (a) + end function + function cat (a) result(r) + character(*), intent(in) :: a(:) + character(12) :: r + r = a(1)//a(2)//a(3)//a(4) + end function + function s_ch (a) result(r) + character(3), intent(in) :: a(4) + character(12) :: r + r = a(1)//a(2)//a(3)//a(4) + end function + subroutine w_ch (a) + character(*), intent(inout) :: a(:) + a = 'zz' + end subroutine + subroutine w_as (a) + integer, intent(inout) :: a(:) + a = a + 1 + end subroutine + subroutine w_ex (a) + integer, intent(inout) :: a(4) + a = a + 1 + end subroutine + subroutine w_out (a) + real(8), intent(out) :: a(:) + a = -5d0 + end subroutine +end module + +program p + use m + implicit none + integer :: k, i, j, ex(4) + real :: rr(2,3) + + ex = [10, 20, 30, 40] + do k = 1, 4 + ta(k) = t(achar(96+k)//'xy', 10*k, 100d0*k, mod(k,2) == 0, & + inner(1000*k, -1d0*k)) + end do + z2 = reshape ([((cmplx (10*i+j, -(10*i+j)), i=1,2), j=1,3)], [2,3]) + rr = -real (reshape ([((10*i+j, i=1,2), j=1,3)], [2,3])) + + if (any (gi() /= ex)) stop 1 + if (sum (gd()) /= 1000d0) stop 2 + if (count (gl()) /= 2) stop 3 + if (any (g2() /= rr)) stop 4 + if (any (pack (gi(), gl()) /= [20, 40])) stop 5 + if (any (gs() /= ['axy', 'bxy', 'cxy', 'dxy'])) stop 6 + + if (s_as (gi()) /= 100) stop 10 + if (s_ex (gi(), 4) /= 100) stop 11 + if (s_sz (gi(), 4) /= 100) stop 12 + if (s_ct (gi()) /= 100) stop 13 + if (s_tg (gi()) /= 100) stop 14 + if (s_pt (gi()) /= 100) stop 15 + if (s_in (gin()) /= 9990d0) stop 16 + if (cnt (gl()) /= 2) stop 17 + if (s2 (g2()) /= sum (rr)) stop 18 + if (cat (gs()) /= 'axybxycxydxy') stop 19 + if (cat (gsub()) /= 'xyxyxyxy') stop 20 + k = 3 + if (cat (gsn(k)) /= 'axybxycxydxy') stop 21 + if (cat (gsd()) /= 'axybxycxydxy') stop 22 + if (s_ch (gsd()) /= 'axybxycxydxy') stop 23 + + call w_as (gi()) + if (any (ta%i /= ex + 1)) stop 30 + call w_ex (gi()) + if (any (ta%i /= ex + 2)) stop 31 + call w_out (gd()) + if (any (ta%d /= -5d0)) stop 32 + gi() = [1, 2, 3, 4] + call w_ch (gsd()) + if (any (ta%s /= 'zz') .or. any (ta%i /= [1, 2, 3, 4])) stop 34 + if (any (ta%i /= [1, 2, 3, 4])) stop 33 + + associate (a => gi()) + if (any (a /= [1, 2, 3, 4])) stop 40 + if (s_as (a) /= 10) stop 41 + a = 7 + end associate + if (any (ta%i /= 7)) stop 42 + associate (a => g2()) + if (s2 (a) /= sum (rr)) stop 43 + end associate +end program
