gcc/testsuite/gfortran.dg/associated_2.f90

   1 ! { dg-do run }
   2 ! Tests the implementation of 13.14.13 of the f95 standard
   3 ! in respect of zero character and zero array length.
   4 !
   5 ! Contributed by Paul Thomas  <pault@gcc.gnu.org>
   6 !
   7   call test1 ()
   8   call test2 ()
   9   call test3 (0)
  10   call test3 (1)
  11 contains
  12   subroutine test1 ()
  13     integer, pointer, dimension(:, :, :)  :: a, b
  14     allocate (a(2,0,2))
  15     b => a
  16 ! Even though b is zero length, associated returns true because
  17 ! the target argument is not present (case (i))
  18     if (.not. associated (b)) call abort ()
  19     deallocate (a)
  20     nullify(a)
  21     if(associated(a,a)) call abort()
  22     allocate (a(2,1,2))
  23     b => a
  24     if (.not.associated (b)) call abort ()
  25     deallocate (a)
  26   end subroutine test1
  27   subroutine test2 ()
  28     integer, pointer, dimension(:, :, :)  :: a, b
  29     allocate (a(2,0,2))
  30     b => a
  31 ! Associated returns false because target is present (case(iii)).
  32     if (associated (b, a)) call abort ()
  33     deallocate (a)
  34     allocate (a(2,1,2))
  35     b => a
  36     if (.not.associated (b, a)) call abort ()
  37     deallocate (a)
  38   end subroutine test2
  39   subroutine test3 (n)
  40     integer :: n
  41     character(len=n), pointer, dimension(:)  :: a, b
  42     allocate (a(2))
  43     b => a
  44 ! Again, with zero character length associated returns false
  45 ! if target is present.
  46     if (associated (b, a) .and. (n .eq. 0)) call abort ()
  47 !
  48     if ((.not.associated (b, a))  .and. (n .ne. 0)) call abort ()
  49     deallocate (a)
  50   end subroutine test3
  51 end