gomp-20050608-branch/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90

   1 ! Program to test the ASSOCIATED intrinsic.
   2 program intrinsic_associated
   3    call pointer_to_section ()
   4    call associate_1 ()
   5    call pointer_to_derived_1 ()
   6    call associated_2 ()
   7 end
   8
   9 subroutine pointer_to_section ()
  10    integer, dimension(5, 5), target :: xy
  11    integer, dimension(:, :), pointer :: window
  12    data xy /25*0/
  13    logical t
  14
  15    window => xy(2:4, 3:4)
  16    window = 10
  17    window (1, 1) = 0101
  18    window (3, 2) = 4161
  19    window (3, 1) = 4101
  20    window (1, 2) = 0161
  21
  22    t = associated (window, xy(2:4, 3:4))
  23    if (.not.t) call abort ()
  24    ! Check that none of the array got mangled
  25    if ((xy(2, 3) .ne. 0101) .or. (xy (4, 4) .ne. 4161) &
  26        .or. (xy(4, 3) .ne. 4101) .or. (xy (2, 4) .ne. 0161)) call abort ()
  27    if (any (xy(:, 1:2) .ne. 0)) call abort ()
  28    if (any (xy(:, 5) .ne. 0)) call abort ()
  29    if (any (xy (1, 3:4) .ne. 0)) call abort ()
  30    if (any (xy (5, 3:4) .ne. 0)) call abort ()
  31    if (xy(3, 3) .ne. 10) call abort ()
  32    if (xy(3, 4) .ne. 10) call abort ()
  33    if (any (xy(2:4, 3:4) .ne. window)) call abort ()
  34 end
  35
  36 subroutine sub1 (a, ap)
  37    integer, pointer :: ap(:, :)
  38    integer, target :: a(10, 10)
  39
  40    ap => a
  41 end
  42
  43 subroutine nullify_pp (a)
  44    integer, pointer :: a(:, :)
  45
  46    if (.not. associated (a)) call abort ()
  47    nullify (a)
  48 end
  49
  50 subroutine associate_1 ()
  51    integer, pointer :: a(:, :), b(:, :)
  52    interface
  53       subroutine nullify_pp (a)
  54          integer, pointer :: a(:, :)
  55       end subroutine nullify_pp
  56    end interface
  57
  58    allocate (a(80, 80))
  59    b => a
  60    if (.not. associated(a)) call abort ()
  61    if (.not. associated(b)) call abort ()
  62    call nullify_pp (a)
  63    if (associated (a)) call abort ()
  64    if (.not. associated (b)) call abort ()
  65 end
  66
  67 subroutine pointer_to_derived_1 ()
  68    type record
  69       integer :: value
  70       type(record), pointer :: rp
  71    end type record
  72
  73    type record1
  74       integer value
  75       type(record2), pointer :: r1p
  76    end type
  77
  78    type record2
  79       integer value
  80       type(record1), pointer :: r2p
  81    end type
  82
  83    type(record), target :: e1, e2, e3
  84    type(record1), target :: r1
  85    type(record2), target :: r2
  86
  87    nullify (r1%r1p, r2%r2p, e1%rp, e2%rp, e3%rp)
  88    if (associated (r1%r1p)) call abort ()
  89    if (associated (r2%r2p)) call abort ()
  90    if (associated (e2%rp)) call abort ()
  91    if (associated (e1%rp)) call abort ()
  92    if (associated (e3%rp)) call abort ()
  93    r1%r1p => r2
  94    r2%r2p => r1
  95    r1%value = 11
  96    r2%value = 22
  97    e1%rp => e2
  98    e2%rp => e3
  99    e1%value = 33
 100    e1%rp%value = 44
 101    e1%rp%rp%value = 55
 102    if (.not. associated (r1%r1p)) call abort ()
 103    if (.not. associated (r2%r2p)) call abort ()
 104    if (.not. associated (e1%rp)) call abort ()
 105    if (.not. associated (e2%rp)) call abort ()
 106    if (associated (e3%rp)) call abort ()
 107    if (r1%r1p%value .ne. 22) call abort ()
 108    if (r2%r2p%value .ne. 11) call abort ()
 109    if (e1%value .ne. 33) call abort ()
 110    if (e2%value .ne. 44) call abort ()
 111    if (e3%value .ne. 55) call abort ()
 112    if (r1%value .ne. 11) call abort ()
 113    if (r2%value .ne. 22) call abort ()
 114
 115 end
 116
 117 subroutine associated_2 ()
 118    integer, pointer :: xp(:, :)
 119    integer, target  :: x(10, 10)
 120    integer, target  :: y(100, 100)
 121    interface
 122       subroutine sub1 (a, ap)
 123          integer, pointer :: ap(:, :)
 124          integer, target  :: a(10, 1)
 125       end
 126    endinterface
 127
 128    xp => y
 129    if (.not. associated (xp)) call abort ()
 130    call sub1 (x, xp)
 131    if (associated (xp, y)) call abort ()
 132    if (.not. associated (xp, x)) call abort ()
 133 end
 134