gcc/testsuite/gfortran.dg/associated_assumed_rank.f90

   1 ! { dg-do run }
   2
   3 ! PR fortran/101334
   4
   5 implicit none (type, external)
   6 real, target :: AT(10,10), BT
   7 real, contiguous, pointer :: A(:,:)
   8 real, pointer :: B
   9 real, pointer :: AP(:,:), BP
  10 real, pointer :: CP(:), DP(:,:), D, EP(:)
  11
  12 call test_char()
  13
  14 A => AT
  15 B => BT
  16
  17 AP => A
  18 BP => B
  19 call foo(AP,B, A, 1) ! OK - associated
  20 call foo(BP,B, A, 2) !  OK - associated
  21
  22 ! Those are all not associated:
  23
  24 AP => null()
  25 BP => null()
  26 call foo(AP, B, A, 3) ! LHS not associated
  27 call foo(BP, B, A, 4) ! LHS not associated
  28
  29 DP => null()
  30 D => null()
  31 call foo(AP, B, DP, 5) ! LHS+RHS not associated
  32 call foo(BP, D, A, 6)  ! LHS+RHS not associated
  33
  34 AP => A
  35 BP => B
  36 call foo(AP, B, DP, 7) ! RHS not associated
  37 call foo(BP, D, A, 8)  ! RHS not associated
  38
  39 CP(1:size(A)) => A
  40 call foo(CP, B, A, 9)  ! Shape (rank) differs
  41
  42 AP => A(2:,:)
  43 call foo(AP, B, A, 10)  ! Shape differs
  44
  45 AP => A(:,2:)
  46 call foo(AP, B, A, 11)  ! Shape differs
  47
  48 AP(10:,10:) => A
  49 call foo(AP, B, A, 12)  ! OK - bounds different, shape same
  50
  51 CP => AT(1:-1, 5)
  52 EP => AT(1:-1, 5)        ! Case(i) + case(iv)
  53 call foo2(CP, EP)  ! CP associated - but CP not associated with EP
  54 contains
  55 subroutine foo2(p, lpd)
  56   implicit none (type, external)
  57   real, pointer :: p(..)    ! "pointer"
  58   real, pointer :: lpd(:) ! array "target"
  59   if (.not.associated(p)) stop 18 ! OK - associated
  60   if (associated(p, lpd)) stop 19 ! .. but for zero-sized array
  61 end
  62
  63 subroutine foo(p, lp, lpd, cnt)
  64   implicit none (type, external)
  65   real, pointer :: p(..)    ! "pointer"
  66   real, pointer :: lp       ! scalar "target"
  67   real, pointer :: lpd(:,:) ! array "target"
  68   integer, value :: cnt
  69
  70   if (cnt == 1) then
  71     if (.not. associated(p, lpd)) stop 1  ! OK
  72   elseif (cnt == 2) then
  73     if (.not. associated(p, lp)) stop 2   ! OK
  74   elseif (cnt == 3) then
  75     if (associated(p, lpd)) stop 3 ! LHS NULL ptr
  76     if (associated(p)) stop 4      ! LHS NULL ptr
  77   elseif (cnt == 4) then
  78     if (associated(p, lp)) stop 5  ! LHS NULL ptr
  79     if (associated(p)) stop 6      ! LHS NULL ptr
  80   elseif (cnt == 5) then
  81     if (associated(p, lpd)) stop 7 ! LHS+RHS NULL ptr
  82     if (associated(p)) stop 8      ! LHS+RHS NULL ptr
  83   elseif (cnt == 6) then
  84     if (associated(p, lp)) stop 9  ! LHS+RHS NULL ptr
  85     if (associated(p)) stop 10      ! LHS+RHS NULL ptr
  86   elseif (cnt == 7) then
  87     if (associated(p, lpd)) stop 11 ! RHS NULL ptr
  88   elseif (cnt == 8) then
  89     if (associated(p, lp)) stop 12  ! RHS NULL ptr
  90   elseif (cnt == 9) then
  91     if (associated(p, lpd)) stop 13 ! rank differs
  92     if (associated(p, lp)) stop 14  ! rank differs
  93   elseif (cnt == 10) then
  94     if (associated(p, lpd)) stop 15 ! shape differs
  95   elseif (cnt == 11) then
  96     if (associated(p, lpd)) stop 16 ! shape differs
  97   elseif (cnt == 12) then
  98     if (.not.associated(p, lpd)) stop 17 ! OK - shape same, lbound different
  99   else
 100     stop 99
 101   endif
 102 end
 103 subroutine test_char()
 104   character(len=0), target :: str0
 105   character(len=2), target :: str2
 106   character(len=:), pointer :: ptr
 107   ptr => str0
 108   call test_char2(ptr, str0)
 109   ptr => str2
 110   call test_char2(ptr, str2)
 111 end
 112 subroutine test_char2(x,y)
 113   character(len=:), pointer :: x
 114   character(len=*), target :: y
 115   if (len(y) == 0) then
 116     if (len(x) /= 0) stop 20
 117     if (.not. associated(x)) stop 21
 118     if (associated(x, y)) stop 22
 119   else
 120     if (len(y) /= 2) stop 23
 121     if (len(x) /= 2) stop 24
 122     if (.not. associated(x)) stop 25
 123     if (.not. associated(x, y)) stop 26
 124   end if
 125 end
 126 end