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.

(cherry picked from commit 3f8b6373f48af0eabbc2efe04df8f6856add3111)

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 08fc524f857889c6b123850e74c2b83eb760c9c4..23d40991dd1418bec0beff9cda10bc2716554c7f 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11222,21 +11222,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 75099ad7cb5000af15436f3d02bd6e6f401343a9..4b68f5759488c904a22999dc3ce0290506b24f2a 100644 (file)
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -2315,10 +2315,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);
@@ -2341,7 +2345,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
     {
@@ -2373,6 +2377,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 (file)
index 0000000..091e43b
--- /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