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