| ! { dg-do run } |
| ! { dg-additional-options "-fdump-tree-original" } |
| ! |
| ! PR fortran/97592 - fix argument passing to CONTIGUOUS,TARGET dummy |
| ! |
| ! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&b_2d" 1 "original" } } |
| ! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&p1" 3 "original" } } |
| ! |
| ! N.B.: there is no reliable count of _gfortran_internal_pack on temporaries parm.* |
| |
| program pr97592 |
| implicit none |
| integer :: i, k |
| integer, target :: a(10) |
| integer, pointer :: p1(:), p2(:), tgt(:), expect(:) |
| integer, pointer, contiguous :: cp(:) |
| integer, allocatable, target :: b(:) |
| |
| !---------------------- |
| ! Code from original PR |
| !---------------------- |
| call RemappingTest () |
| |
| !--------------------- |
| ! Additional 1-d tests |
| !--------------------- |
| a = [(i, i=1,size(a))] |
| b = a |
| |
| ! Set p1 to an actually contiguous pointer |
| p1(13:) => a(3::2) |
| print *, lbound (p1), ubound (p1), is_contiguous (p1) |
| |
| ! non-contiguous pointer actual argument |
| expect => p1 |
| call chk_cont (p1) |
| |
| expect => p1 |
| call chk_tgt_cont (p1) |
| |
| expect => p1 |
| call chk_ptr (p1, p2) |
| if (any (p2 /= p1)) stop 1 |
| |
| expect => p1 |
| call chk_tgt (p1, p2) |
| if (any (p2 /= p1)) stop 2 |
| |
| ! non-contiguous target actual argument |
| expect => b(3::2) |
| call chk_tgt_cont (b(3::2)) |
| |
| expect => b(3::2) |
| call chk_tgt (b(3::2), p2) |
| if (any (p2 /= p1)) stop 3 |
| |
| expect => b(3::2) |
| call chk_ptr (b(3::2), p2) |
| if (any (p2 /= p1)) stop 4 |
| |
| ! Set p1 to an actually contiguous pointer |
| cp(17:) => a(3:9:1) |
| p1 => cp |
| print *, lbound (cp), ubound (cp), is_contiguous (cp) |
| print *, lbound (p1), ubound (p1), is_contiguous (p1) |
| |
| expect => p1 |
| call chk_tgt (p1, p2) |
| if (any (p2 /= cp)) stop 31 |
| |
| expect => cp |
| call chk_tgt (cp, p2) |
| if (any (p2 /= cp)) stop 32 |
| |
| expect => cp |
| call chk_tgt_cont (cp, p2) |
| if (any (p2 /= cp)) stop 33 |
| |
| expect => cp |
| call chk_tgt_expl (cp, p2, size (cp)) |
| if (any (p2 /= cp)) stop 34 |
| |
| ! See F2018:15.5.2.4 and F2018:C.10.4 |
| expect => p1 |
| call chk_tgt_cont (p1, p2) |
| ! print *, p2 |
| if (any (p2 /= cp)) stop 35 |
| |
| expect => p1 |
| call chk_tgt_expl (p1, p2, size (p1)) |
| if (any (p2 /= cp)) stop 36 |
| |
| expect => cp |
| call chk_ptr_cont (cp, p2) |
| if (any (p2 /= cp)) stop 37 |
| |
| ! Pass array section which is actually contigous |
| k = 1 |
| expect => cp(::k) |
| call chk_ptr (cp(::k), p2) |
| if (any (p2 /= cp(::k))) stop 38 |
| |
| expect => p1(::k) |
| call chk_tgt_cont (p1(::k), p2) |
| if (any (p2 /= p1(::k))) stop 39 |
| |
| expect => p1(::k) |
| call chk_tgt (p1(::k), p2) |
| if (any (p2 /= p1(::k))) stop 40 |
| |
| expect => p1(::k) |
| call chk_tgt_expl (p1(::k), p2, size (p1(::k))) |
| if (any (p2 /= p1(::k))) stop 41 |
| |
| expect => b(3::k) |
| call chk_tgt_cont (b(3::k), p2) |
| if (any (p2 /= b(3::k))) stop 42 |
| |
| expect => b(3::k) |
| call chk_tgt (b(3::k), p2) |
| if (any (p2 /= b(3::k))) stop 43 |
| |
| expect => b(3::k) |
| call chk_tgt_expl (b(3::k), p2, size (b(3::k))) |
| if (any (p2 /= b(3::k))) stop 44 |
| |
| if (any (a /= [(i, i=1,size(a))])) stop 66 |
| if (any (a /= b)) stop 77 |
| deallocate (b) |
| |
| contains |
| ! Contiguous pointer dummy |
| subroutine chk_ptr_cont (x, y) |
| integer, contiguous, pointer, intent(in) :: x(:) |
| integer, pointer, optional :: y(:) |
| print *, lbound (x), ubound (x) |
| if (present (y)) y => x(:) |
| if (associated (expect)) then |
| if (size (x) /= size (expect)) stop 10 |
| if (any (x /= expect)) stop 11 |
| if (lbound(expect,1) /= 1 .and. & |
| lbound(expect,1) /= lbound (x,1)) stop 20 |
| end if |
| end |
| |
| ! Pointer dummy |
| subroutine chk_ptr (x, y) |
| integer, pointer, intent(in) :: x(:) |
| integer, pointer, optional :: y(:) |
| print *, lbound (x), ubound (x) |
| if (present (y)) y => x(:) |
| if (associated (expect)) then |
| if (size (x) /= size (expect)) stop 12 |
| if (any (x /= expect)) stop 13 |
| if (lbound(expect,1) /= 1 .and. & |
| lbound(expect,1) /= lbound (x,1)) stop 22 |
| end if |
| end |
| |
| ! Dummy with target attribute |
| subroutine chk_tgt_cont (x, y) |
| integer, contiguous, target, intent(in) :: x(:) |
| integer, pointer, optional :: y(:) |
| if (present (y)) y => x(:) |
| if (associated (expect)) then |
| if (size (x) /= size (expect)) stop 14 |
| if (any (x /= expect)) stop 15 |
| end if |
| end |
| |
| subroutine chk_tgt (x, y) |
| integer, target, intent(in) :: x(:) |
| integer, pointer, optional :: y(:) |
| if (present (y)) y => x(:) |
| if (associated (expect)) then |
| if (size (x) /= size (expect)) stop 16 |
| if (any (x /= expect)) stop 17 |
| end if |
| end |
| |
| ! Explicit-shape dummy with target attribute |
| subroutine chk_tgt_expl (x, y, n) |
| integer, intent(in) :: n |
| integer, target, intent(in) :: x(n) |
| integer, pointer, optional :: y(:) |
| if (present (y)) y => x(:) |
| if (associated (expect)) then |
| if (size (x) /= size (expect)) stop 18 |
| if (any (x /= expect)) stop 19 |
| end if |
| end |
| |
| ! Dummy without pointer or target attribute |
| subroutine chk_cont (x) |
| integer, contiguous, intent(in) :: x(:) |
| if (associated (expect)) then |
| if (size (x) /= size (expect)) stop 23 |
| if (any (x /= expect)) stop 24 |
| end if |
| end |
| |
| !------------------------------------------------------------------------ |
| |
| subroutine RemappingTest () |
| real, pointer :: B_2D(:,:) |
| real, pointer :: B_3D(:,:,:) => NULL() |
| integer, parameter :: n1=4, n2=4, n3=3 |
| !-- Prepare B_2D |
| allocate (B_2D(n1*n2, n3)) |
| B_2D = - huge (1.0) |
| if (.not. is_contiguous (B_2D)) stop 101 |
| !-- Point B_3D to Storage |
| call SetPointer (B_2D, n1, n2, n3, B_3D) |
| !print *,"is_contiguous (B_3D) =", is_contiguous (B_3D) |
| if (.not. is_contiguous (B_3D)) stop 102 |
| !-- Set B_3D |
| B_3D = 2.0 |
| !-- See if the result is reflected in Storage |
| if (any (B_2D /= 2.0)) then |
| print *, "B_2D = ", B_2D !-- expect 2.0 for all elements |
| stop 103 |
| end if |
| print *,"RemappingTest passed" |
| end |
| |
| subroutine SetPointer (C_2D, n1, n2, n3, C_3D) |
| integer, intent(in) :: n1, n2, n3 |
| real, target, contiguous :: C_2D(:,:) |
| real, pointer :: C_3D(:,:,:) |
| intent(in) :: C_2D |
| C_3D(1:n1,1:n2,1:n3) => C_2D |
| end |
| |
| end |
