Fortran: add contiguous check for ptr assignment, fix non-contig check (PR97242)

gcc/fortran/ChangeLog:

	PR fortran/97242
	* expr.c (gfc_is_not_contiguous): Fix check.
	(gfc_check_pointer_assign): Use it.

gcc/testsuite/ChangeLog:

	PR fortran/97242
	* gfortran.dg/contiguous_11.f90: New test.
	* gfortran.dg/contiguous_4.f90: Update.
	* gfortran.dg/contiguous_7.f90: Update.

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 68784a235f146f9d7b55e6c3ad374934b5b9f244..b87ae3d72a18ea0e3f5599a2b8e6500b6fb8568a 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4366,10 +4366,18 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
      contiguous.  */
 
   if (lhs_attr.contiguous
-      && lhs_attr.dimension > 0
-      && !gfc_is_simply_contiguous (rvalue, false, true))
-    gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from "
-                "non-contiguous target at %L", &rvalue->where);
+      && lhs_attr.dimension > 0)
+    {
+      if (gfc_is_not_contiguous (rvalue))
+       {
+         gfc_error ("Assignment to contiguous pointer from "
+                    "non-contiguous target at %L", &rvalue->where);
+         return false;
+       }
+      if (!gfc_is_simply_contiguous (rvalue, false, true))
+       gfc_warning (OPT_Wextra, "Assignment to contiguous pointer from "
+                                "non-contiguous target at %L", &rvalue->where);
+    }
 
   /* Warn if it is the LHS pointer may lives longer than the RHS target.  */
   if (warn_target_lifetime
@@ -5935,7 +5943,7 @@ gfc_is_not_contiguous (gfc_expr *array)
     {
       /* Array-ref shall be last ref.  */
 
-      if (ar)
+      if (ar && ar->type != AR_ELEMENT)
        return true;
 
       if (ref->type == REF_ARRAY)
@@ -5955,10 +5963,11 @@ gfc_is_not_contiguous (gfc_expr *array)
 
       if (gfc_ref_dimen_size (ar, i, &ref_size, NULL))
        {
-         if (gfc_dep_difference (ar->as->lower[i], ar->as->upper[i], &arr_size))
+         if (gfc_dep_difference (ar->as->upper[i], ar->as->lower[i], &arr_size))
            {
              /* a(2:4,2:) is known to be non-contiguous, but
                 a(2:4,i:i) can be contiguous.  */
+             mpz_add_ui (arr_size, arr_size, 1L);
              if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0)
                {
                  mpz_clear (arr_size);
@@ -5979,7 +5988,10 @@ gfc_is_not_contiguous (gfc_expr *array)
              && ar->dimen_type[i] == DIMEN_RANGE
              && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT
              && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)
-           return true;
+           {
+             mpz_clear (ref_size);
+             return true;
+           }
 
          mpz_clear (ref_size);
        }

diff --git a/gcc/testsuite/gfortran.dg/contiguous_11.f90 b/gcc/testsuite/gfortran.dg/contiguous_11.f90
new file mode 100644 (file)
index 0000000..b7eb7bf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/contiguous_11.f90
@@ -0,0 +1,45 @@
+! { dg-do compile }
+!
+! PR fortran/97242
+!
+implicit none
+type t
+  integer, allocatable :: A(:,:,:)
+  integer :: D(5,5,5)
+end type t
+
+type(t), target :: B(5)
+integer, pointer, contiguous :: P(:,:,:)
+integer, target :: C(5,5,5)
+integer :: i
+
+i = 1
+
+! OK: contiguous
+P => B(i)%A
+P => B(i)%A(:,:,:)
+P => C
+P => C(:,:,:)
+call foo (B(i)%A)
+call foo (B(i)%A(:,:,:))
+call foo (C)
+call foo (C(:,:,:))
+
+! Invalid - not contiguous
+! "If the pointer object has the CONTIGUOUS attribute, the pointer target shall be contiguous."
+! → known to be noncontigous (not always checkable, however)
+P => B(i)%A(:,::3,::4)   ! <<< Unknown as (1:2:3,1:3:4) is contiguous and has one element.
+P => B(i)%D(:,::2,::2)   ! { dg-error "Assignment to contiguous pointer from non-contiguous target" }
+P => C(::2,::2,::2)      ! { dg-error "Assignment to contiguous pointer from non-contiguous target" }
+
+! This following is stricter:
+! C1541  The actual argument corresponding to a dummy pointer with the
+!        CONTIGUOUS attribute shall be simply contiguous (9.5.4).
+call foo (B(i)%A(:,::3,::4))  ! { dg-error "must be simply contiguous" }
+call foo (C(::2,::2,::2))     ! { dg-error "must be simply contiguous" }
+
+contains
+  subroutine foo(Q)
+    integer, pointer, intent(in), contiguous :: Q(:,:,:)
+  end subroutine foo
+end

diff --git a/gcc/testsuite/gfortran.dg/contiguous_4.f90 b/gcc/testsuite/gfortran.dg/contiguous_4.f90
index 874ef8ba9ecd8c97336d7bb6d7d21437e640844f..e784287c00d8829131a1021bba5189272659c338 100644 (file)
--- a/gcc/testsuite/gfortran.dg/contiguous_4.f90
+++ b/gcc/testsuite/gfortran.dg/contiguous_4.f90
@@ -10,8 +10,10 @@ program cont_01_neg
 
   x = (/ (real(i),i=1,45) /)
   x2 = reshape(x,shape(x2))
-  r => x(::3)
-  r2 => x2(2:,:)
+  r => x(::46)  
+  r => x(::3) ! { dg-error "Assignment to contiguous pointer from non-contiguous target" }
+  r2 => x2(2:,9:)
+  r2 => x2(2:,:)  ! { dg-error "Assignment to contiguous pointer from non-contiguous target" }
   r2 => x2(:,2:3)
   r => x2(2:3,1)
   r => x(::1)

diff --git a/gcc/testsuite/gfortran.dg/contiguous_7.f90 b/gcc/testsuite/gfortran.dg/contiguous_7.f90
index cccc89f9ba498fb80688ab0f48ab55e71640f191..7444b4c5c30d29eb350c4b879301fc1c9fbd3bc3 100644 (file)
--- a/gcc/testsuite/gfortran.dg/contiguous_7.f90
+++ b/gcc/testsuite/gfortran.dg/contiguous_7.f90
@@ -8,17 +8,29 @@ program cont_01_neg
   implicit none
   real, pointer, contiguous :: r(:)
   real, pointer, contiguous :: r2(:,:)
-  real, target :: x(45)
-  real, target :: x2(5,9)
+  real, target, allocatable :: x(:)
+  real, target, allocatable :: x2(:,:)
+  real, target :: y(45)
+  real, target :: y2(5,9)
   integer :: i
   integer :: n=1
 
   x = (/ (real(i),i=1,45) /)
   x2 = reshape(x,shape(x2))
+  y = x
+  y2 = x2
+
   r => x(::3) ! { dg-warning "ssignment to contiguous pointer from non-contiguous target" }
   r2 => x2(2:,:) ! { dg-warning "ssignment to contiguous pointer from non-contiguous target" }
   r2 => x2(:,2:3)
   r => x2(2:3,1)
   r => x(::1)
   r => x(::n) ! { dg-warning "ssignment to contiguous pointer from non-contiguous target" }
+
+  r => y(::3) ! { dg-error "ssignment to contiguous pointer from non-contiguous target" }
+  r2 => y2(2:,:) ! { dg-error "ssignment to contiguous pointer from non-contiguous target" }
+  r2 => y2(:,2:3)
+  r => y2(2:3,1)
+  r => y(::1)
+  r => y(::n) ! { dg-warning "ssignment to contiguous pointer from non-contiguous target" }
 end program