blob: 8bb7ea158c9b80dd1258b94c8de2cfdfbb9a03d9 [file] [log] [blame]
! { dg-do run }
! PR fortran/101334
implicit none (type, external)
real, target :: AT(10,10), BT
real, contiguous, pointer :: A(:,:)
real, pointer :: B
real, pointer :: AP(:,:), BP
real, pointer :: CP(:), DP(:,:), D, EP(:)
call test_char()
A => AT
B => BT
AP => A
BP => B
call foo(AP,B, A, 1) ! OK - associated
call foo(BP,B, A, 2) ! OK - associated
! Those are all not associated:
AP => null()
BP => null()
call foo(AP, B, A, 3) ! LHS not associated
call foo(BP, B, A, 4) ! LHS not associated
DP => null()
D => null()
call foo(AP, B, DP, 5) ! LHS+RHS not associated
call foo(BP, D, A, 6) ! LHS+RHS not associated
AP => A
BP => B
call foo(AP, B, DP, 7) ! RHS not associated
call foo(BP, D, A, 8) ! RHS not associated
CP(1:size(A)) => A
call foo(CP, B, A, 9) ! Shape (rank) differs
AP => A(2:,:)
call foo(AP, B, A, 10) ! Shape differs
AP => A(:,2:)
call foo(AP, B, A, 11) ! Shape differs
AP(10:,10:) => A
call foo(AP, B, A, 12) ! OK - bounds different, shape same
CP => AT(1:-1, 5)
EP => AT(1:-1, 5) ! Case(i) + case(iv)
call foo2(CP, EP) ! CP associated - but CP not associated with EP
contains
subroutine foo2(p, lpd)
implicit none (type, external)
real, pointer :: p(..) ! "pointer"
real, pointer :: lpd(:) ! array "target"
if (.not.associated(p)) stop 18 ! OK - associated
if (associated(p, lpd)) stop 19 ! .. but for zero-sized array
end
subroutine foo(p, lp, lpd, cnt)
implicit none (type, external)
real, pointer :: p(..) ! "pointer"
real, pointer :: lp ! scalar "target"
real, pointer :: lpd(:,:) ! array "target"
integer, value :: cnt
if (cnt == 1) then
if (.not. associated(p, lpd)) stop 1 ! OK
elseif (cnt == 2) then
if (.not. associated(p, lp)) stop 2 ! OK
elseif (cnt == 3) then
if (associated(p, lpd)) stop 3 ! LHS NULL ptr
if (associated(p)) stop 4 ! LHS NULL ptr
elseif (cnt == 4) then
if (associated(p, lp)) stop 5 ! LHS NULL ptr
if (associated(p)) stop 6 ! LHS NULL ptr
elseif (cnt == 5) then
if (associated(p, lpd)) stop 7 ! LHS+RHS NULL ptr
if (associated(p)) stop 8 ! LHS+RHS NULL ptr
elseif (cnt == 6) then
if (associated(p, lp)) stop 9 ! LHS+RHS NULL ptr
if (associated(p)) stop 10 ! LHS+RHS NULL ptr
elseif (cnt == 7) then
if (associated(p, lpd)) stop 11 ! RHS NULL ptr
elseif (cnt == 8) then
if (associated(p, lp)) stop 12 ! RHS NULL ptr
elseif (cnt == 9) then
if (associated(p, lpd)) stop 13 ! rank differs
if (associated(p, lp)) stop 14 ! rank differs
elseif (cnt == 10) then
if (associated(p, lpd)) stop 15 ! shape differs
elseif (cnt == 11) then
if (associated(p, lpd)) stop 16 ! shape differs
elseif (cnt == 12) then
if (.not.associated(p, lpd)) stop 17 ! OK - shape same, lbound different
else
stop 99
endif
end
subroutine test_char()
character(len=0), target :: str0
character(len=2), target :: str2
character(len=:), pointer :: ptr
ptr => str0
call test_char2(ptr, str0)
ptr => str2
call test_char2(ptr, str2)
end
subroutine test_char2(x,y)
character(len=:), pointer :: x
character(len=*), target :: y
if (len(y) == 0) then
if (len(x) /= 0) stop 20
if (.not. associated(x)) stop 21
if (associated(x, y)) stop 22
else
if (len(y) /= 2) stop 23
if (len(x) /= 2) stop 24
if (.not. associated(x)) stop 25
if (.not. associated(x, y)) stop 26
end if
end
end