Dear All, this patch does two things: it extends the inline generated code for IS_CONTIGUOUS to check the dtype of a passed pointer for span equal to elem_len. It also fixes the assignment of pointers to ensure that the dtype is the same whether bounds-remapping is done or not.
While developing the testcase, I discovered cases where there is an implicit dummy pointer,intent(in) assignment to a non-contiguous target and which don't work. One of these cases is tracked in PR122397. Regtested on x86_64-pc-linux-gnu. OK for mainline and 15-branch? Thanks, Harald
From 652e1e8f6041c2f15dbe6110eec8d6da6b1dd4a8 Mon Sep 17 00:00:00 2001 From: Harald Anlauf <[email protected]> Date: Fri, 24 Oct 2025 21:33:08 +0200 Subject: [PATCH] Fortran: IS_CONTIGUOUS and pointers to non-contiguous targets [PR114023] PR fortran/114023 gcc/fortran/ChangeLog: * trans-expr.cc (gfc_trans_pointer_assignment): Always set dtype when remapping a pointer. For unlimited polymorphic LHS use elem_len from RHS. * trans-intrinsic.cc (gfc_conv_is_contiguous_expr): Extend inline generated code for IS_CONTIGUOUS for pointer arguments to detect when span differs from the element size. gcc/testsuite/ChangeLog: * gfortran.dg/is_contiguous_5.f90: New test. --- gcc/fortran/trans-expr.cc | 24 +++- gcc/fortran/trans-intrinsic.cc | 22 ++- gcc/testsuite/gfortran.dg/is_contiguous_5.f90 | 126 ++++++++++++++++++ 3 files changed, 165 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/is_contiguous_5.f90 diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 21f256b280f..67b60c78aa7 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -11344,21 +11344,33 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) int dim; gcc_assert (remap->u.ar.dimen == expr1->rank); + /* Always set dtype. */ + tree dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_get_dtype (TREE_TYPE (desc)); + gfc_add_modify (&block, dtype, tmp); + + /* For unlimited polymorphic LHS use elem_len from RHS. */ + if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS) + { + tree elem_len; + tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts)); + elem_len = fold_convert (gfc_array_index_type, tmp); + elem_len = gfc_evaluate_now (elem_len, &block); + tmp = gfc_conv_descriptor_elem_len (desc); + gfc_add_modify (&block, tmp, + fold_convert (TREE_TYPE (tmp), elem_len)); + } + if (rank_remap) { /* Do rank remapping. We already have the RHS's descriptor converted in rse and now have to build the correct LHS descriptor for it. */ - tree dtype, data, span; + tree data, span; tree offs, stride; tree lbound, ubound; - /* Set dtype. */ - dtype = gfc_conv_descriptor_dtype (desc); - tmp = gfc_get_dtype (TREE_TYPE (desc)); - gfc_add_modify (&block, dtype, tmp); - /* Copy data pointer. */ data = gfc_conv_descriptor_data_get (rse.expr); gfc_conv_descriptor_data_set (&block, desc, data); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 05017d00a0f..89a03d874ec 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -2316,10 +2316,14 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) int i; tree fncall0; gfc_array_spec *as; + gfc_symbol *sym = NULL; if (arg->ts.type == BT_CLASS) gfc_add_class_array_ref (arg); + if (arg->expr_type == EXPR_VARIABLE) + sym = arg->symtree->n.sym; + ss = gfc_walk_expr (arg); gcc_assert (ss != gfc_ss_terminator); gfc_init_se (&argse, NULL); @@ -2342,7 +2346,7 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) fncall0 = build_call_expr_loc (input_location, gfor_fndecl_is_contiguous0, 1, desc); se->expr = fncall0; - se->expr = convert (logical_type_node, se->expr); + se->expr = convert (boolean_type_node, se->expr); } else { @@ -2374,6 +2378,22 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) } se->expr = cond; } + + /* A pointer that does not have the CONTIGUOUS attribute needs to be checked + if it points to an array whose span differs from the element size. */ + if (as && sym && IS_POINTER(sym) && !sym->attr.contiguous) + { + tree span = gfc_conv_descriptor_span_get (desc); + tmp = fold_convert (TREE_TYPE (span), + gfc_conv_descriptor_elem_len (desc)); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + span, tmp); + se->expr = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, + convert (boolean_type_node, se->expr)); + } + + gfc_free_ss_chain (ss); } diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_5.f90 b/gcc/testsuite/gfortran.dg/is_contiguous_5.f90 new file mode 100644 index 00000000000..091e43b55c2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/is_contiguous_5.f90 @@ -0,0 +1,126 @@ +! { dg-do run } +! PR fortran/114023 - IS_CONTIGUOUS and pointers to non-contiguous targets +! +! Based on testcase by Federico Perini + +program main + implicit none + complex, parameter :: cvals(*) = [(1,-1),(2,-2),(3,-3)] + complex , target :: cref(size(cvals)) = cvals ! Reference + complex, allocatable, target :: carr(:) ! Test + + type cx + real :: re, im + end type cx + type(cx), parameter :: tvals(*) = [cx(1,-1),cx(2,-2),cx(3,-3)] + real, parameter :: expect(*) = tvals% re + type(cx) , target :: tref(size(cvals)) = tvals ! Reference + type(cx), allocatable, target :: tarr(:) + + real, pointer :: rr1(:), rr2(:), rr3(:), rr4(:) + class(*), pointer :: cp1(:), cp2(:), cp3(:), cp4(:) + + carr = cvals + tarr = tvals + + if (any (expect /= [1,2,3])) error stop 90 + + ! REAL pointer to non-contiguous effective target + rr1(1:3) => cref%re + rr2 => cref%re + rr3(1:3) => carr%re + rr4 => carr%re + + if (is_contiguous (rr1)) stop 1 + if (my_contiguous_real (rr1)) stop 2 + if (is_contiguous (cref(1:3)%re)) stop 3 +! if (my_contiguous_real (cref(1:3)%re)) stop 4 ! pr122397 + + if (is_contiguous (rr3)) stop 6 + if (my_contiguous_real (rr3)) stop 7 + if (is_contiguous (carr(1:3)%re)) stop 8 +! if (my_contiguous_real (carr(1:3)%re)) stop 9 + + if (is_contiguous (rr2)) stop 11 + if (my_contiguous_real (rr2)) stop 12 + if (is_contiguous (cref%re)) stop 13 +! if (my_contiguous_real (cref%re)) stop 14 + + if (is_contiguous (rr4)) stop 16 + if (my_contiguous_real (rr4)) stop 17 + if (is_contiguous (carr%re)) stop 18 +! if (my_contiguous_real (carr%re)) stop 19 + + rr1(1:3) => tref%re + rr2 => tref%re + rr3(1:3) => tarr%re + rr4 => tarr%re + + if (is_contiguous (rr1)) stop 21 + if (my_contiguous_real (rr1)) stop 22 + if (is_contiguous (tref(1:3)%re)) stop 23 +! if (my_contiguous_real (tref(1:3)%re)) stop 24 + + if (is_contiguous (rr3)) stop 26 + if (my_contiguous_real (rr3)) stop 27 + if (is_contiguous (tarr(1:3)%re)) stop 28 +! if (my_contiguous_real (tarr(1:3)%re)) stop 29 + + if (is_contiguous (rr2)) stop 31 + if (my_contiguous_real (rr2)) stop 32 + if (is_contiguous (tref%re)) stop 33 +! if (my_contiguous_real (tref%re)) stop 34 + + if (is_contiguous (rr4)) stop 36 + if (my_contiguous_real (rr4)) stop 37 + if (is_contiguous (tarr%re)) stop 38 +! if (my_contiguous_real (tarr%re)) stop 39 + + ! Unlimited polymorphic pointer to non-contiguous effective target + cp1(1:3) => cref%re + cp2 => cref%re + cp3(1:3) => carr%re + cp4 => carr%re + + if (is_contiguous (cp1)) stop 41 + if (my_contiguous_poly (cp1)) stop 42 + if (is_contiguous (cp2)) stop 43 + if (my_contiguous_poly (cp2)) stop 44 + if (is_contiguous (cp3)) stop 45 + if (my_contiguous_poly (cp3)) stop 46 + if (is_contiguous (cp4)) stop 47 + if (my_contiguous_poly (cp4)) stop 48 + + cp1(1:3) => tref%re + cp2 => tref%re + cp3(1:3) => tarr%re + cp4 => tarr%re + + if (is_contiguous (cp1)) stop 51 + if (my_contiguous_poly (cp1)) stop 52 + if (is_contiguous (cp2)) stop 53 + if (my_contiguous_poly (cp2)) stop 54 + if (is_contiguous (cp3)) stop 55 + if (my_contiguous_poly (cp3)) stop 56 + if (is_contiguous (cp4)) stop 57 + if (my_contiguous_poly (cp4)) stop 58 + + deallocate (carr, tarr) +contains + pure logical function my_contiguous_real (x) result (res) + real, pointer, intent(in) :: x(:) + res = is_contiguous (x) + if (any (x /= expect)) error stop 97 + end function my_contiguous_real + + pure logical function my_contiguous_poly (x) result (res) + class(*), pointer, intent(in) :: x(:) + res = is_contiguous (x) + select type (x) + type is (real) + if (any (x /= expect)) error stop 98 + class default + error stop 99 + end select + end function my_contiguous_poly +end -- 2.51.0
