See attached patch. When a pointer array function returns a pointer to
a component of a derived-type array, or to the real or imaginary part of
a complex array, the elements of the result are spaced by the span of
its descriptor, not by the element size. The caller indexed the result
by the element size, so expressions, ASSOCIATE names, SELECT TYPE on a
CLASS pointer associated with the result, and actual arguments all saw
the wrong elements. The fix makes each of these uses honor the span. An
actual argument for a dummy that does not accept a span is copied in and
out, but only when a run-time check finds the elements are not already
laid out as the dummy expects.
Regression tested on x86_64.
OK for mainline?
Regards,
Jerry
---
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 (conv_pointer_result_arg): New function.
(gfc_conv_procedure_call): Pass a pointer array function result
to a non-pointer dummy through conv_pointer_result_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.
>From e61d486d6589c6df90f4305fec7f2330be7cb2e7 Mon Sep 17 00:00:00 2001
From: Jerry DeLisle <[email protected]>
Date: Sun, 4 Oct 2026 16:21:46 -0700
Subject: [PATCH] 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 (conv_pointer_result_arg): New function.
(gfc_conv_procedure_call): Pass a pointer array function result
to a non-pointer dummy through conv_pointer_result_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.
---
gcc/fortran/expr.cc | 5 +-
gcc/fortran/resolve.cc | 5 +
gcc/fortran/trans-expr.cc | 65 +++++++
.../gfortran.dg/pointer_function_span_1.f90 | 72 +++++++
.../gfortran.dg/pointer_function_span_2.f90 | 180 ++++++++++++++++++
5 files changed, 326 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/pointer_function_span_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/pointer_function_span_2.f90
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index ac08d9375f5..e583ed04643 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -4736,7 +4736,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
if (rvalue->expr_type == EXPR_NULL)
return true;
- if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+ /* The elements of a subreference array or a pointer function result may
+ be spaced by more than the element size. */
+ if ((rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+ || (rvalue->rank > 0 && gfc_is_ptr_fcn (rvalue)))
lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
attr = gfc_expr_attr (rvalue);
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 401431252d1..e24a0c19eac 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10835,6 +10835,11 @@ 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->rank > 0 && gfc_is_ptr_fcn (target))
+ 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 b4491e7d670..27b0ec1f3ce 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7487,6 +7487,54 @@ copy_in_out_allowed (gfc_symbol *fsym, gfc_expr *e, bool nodesc_arg)
}
+/* Convert the pointer array function reference E, an actual argument for
+ the dummy FSYM of PROC_NAME, by gfc_conv_subref_array_arg. The result
+ is held in a temporary pointer, so that E is evaluated only once. */
+
+static void
+conv_pointer_result_arg (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
+ bool nodesc_arg, const char *proc_name)
+{
+ 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 (&parmse->pre, &se.pre);
+ gfc_add_block_to_block (&parmse->pre, &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,
+ &parmse->pre);
+ }
+
+ gfc_expr *var = gfc_get_variable_expr (st);
+ var->where = e->where;
+ gfc_conv_subref_array_arg (parmse, var, nodesc_arg,
+ fsym ? fsym->attr.intent : INTENT_INOUT, false,
+ fsym, proc_name, NULL, true, false,
+ dummy_accepts_strided_arg (fsym, nodesc_arg));
+ gfc_free_expr (var);
+ gfc_free_symbol (sym);
+ XDELETE (st);
+}
+
+
/* 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.
@@ -8571,6 +8619,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
? e->symtree->n.sym : NULL,
false, true);
+ else if (e->ts.type != BT_CLASS
+ && gfc_is_ptr_fcn (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. */
+ conv_pointer_result_arg (&parmse, e, fsym, nodesc_arg,
+ sym->name);
+
else if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e)
&& !(fsym && fsym->attr.pointer)
@@ -9395,6 +9452,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);
@@ -9431,6 +9492,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 00000000000..75e399df402
--- /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 00000000000..1d709a800ef
--- /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]
+ if (any (ta%i /= [1, 2, 3, 4])) stop 33
+ call w_ch (gsd())
+ if (any (ta%s /= 'zz') .or. any (ta%i /= [1, 2, 3, 4])) stop 34
+
+ 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
--
2.56.0
