From 65167982efa4dbb96698d026e6d7e17acb513f0a Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Wed, 30 Sep 2020 15:01:13 +0200 Subject: [PATCH] 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. --- gcc/fortran/expr.c | 26 ++++++++---- gcc/testsuite/gfortran.dg/contiguous_11.f90 | 45 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/contiguous_4.f90 | 6 ++- gcc/testsuite/gfortran.dg/contiguous_7.f90 | 16 +++++++- 4 files changed, 82 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/contiguous_11.f90 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 68784a235f1..b87ae3d72a1 100644 --- 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 index 00000000000..b7eb7bfd0b4 --- /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 874ef8ba9ec..e784287c00d 100644 --- 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 cccc89f9ba4..7444b4c5c30 100644 --- 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 -- 2.30.2