summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.fortran-torture/execute/intrinsic_associated.f90
blob: 586f766010a6a30a5df18c58a61b449e8278486d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
! Program to test the ASSOCIATED intrinsic.
program intrinsic_associated
   call pointer_to_section ()
   call associate_1 ()
   call pointer_to_derived_1 ()
   call associated_2 ()
end

subroutine pointer_to_section ()
   integer, dimension(5, 5), target :: xy
   integer, dimension(:, :), pointer :: window
   data xy /25*0/
   logical t

   window => xy(2:4, 3:4)
   window = 10
   window (1, 1) = 0101
   window (3, 2) = 4161
   window (3, 1) = 4101
   window (1, 2) = 0161

   t = associated (window, xy(2:4, 3:4))
   if (.not.t) call abort ()
   ! Check that none of the array got mangled
   if ((xy(2, 3) .ne. 0101) .or. (xy (4, 4) .ne. 4161) &
       .or. (xy(4, 3) .ne. 4101) .or. (xy (2, 4) .ne. 0161)) call abort ()
   if (any (xy(:, 1:2) .ne. 0)) call abort ()
   if (any (xy(:, 5) .ne. 0)) call abort ()
   if (any (xy (1, 3:4) .ne. 0)) call abort ()
   if (any (xy (5, 3:4) .ne. 0)) call abort ()
   if (xy(3, 3) .ne. 10) call abort ()
   if (xy(3, 4) .ne. 10) call abort ()
   if (any (xy(2:4, 3:4) .ne. window)) call abort ()
end

subroutine sub1 (a, ap)
   integer, pointer :: ap(:, :)
   integer, target :: a(10, 10)

   ap => a
end

subroutine nullify_pp (a)
   integer, pointer :: a(:, :)

   if (.not. associated (a)) call abort ()
   nullify (a)
end

subroutine associate_1 ()
   integer, pointer :: a(:, :), b(:, :)
   interface 
      subroutine nullify_pp (a)
         integer, pointer :: a(:, :)
      end subroutine nullify_pp
   end interface

   allocate (a(80, 80))
   b => a
   if (.not. associated(a)) call abort ()
   if (.not. associated(b)) call abort ()
   call nullify_pp (a)
   if (associated (a)) call abort ()
   if (.not. associated (b)) call abort ()
end

subroutine pointer_to_derived_1 ()
   type record
      integer :: value
      type(record), pointer :: rp
   end type record

   type record1
      integer value
      type(record2), pointer :: r1p
   end type

   type record2
      integer value
      type(record1), pointer :: r2p
   end type

   type(record), target :: e1, e2, e3
   type(record1), target :: r1
   type(record2), target :: r2

   nullify (r1%r1p, r2%r2p, e1%rp, e2%rp, e3%rp)
   if (associated (r1%r1p)) call abort ()
   if (associated (r2%r2p)) call abort ()
   if (associated (e2%rp)) call abort ()
   if (associated (e1%rp)) call abort ()
   if (associated (e3%rp)) call abort ()
   r1%r1p => r2
   r2%r2p => r1
   r1%value = 11
   r2%value = 22
   e1%rp => e2
   e2%rp => e3
   e1%value = 33
   e1%rp%value = 44
   e1%rp%rp%value = 55
   if (.not. associated (r1%r1p)) call abort ()
   if (.not. associated (r2%r2p)) call abort ()
   if (.not. associated (e1%rp)) call abort ()
   if (.not. associated (e2%rp)) call abort ()
   if (associated (e3%rp)) call abort ()
   if (r1%r1p%value .ne. 22) call abort ()
   if (r2%r2p%value .ne. 11) call abort ()
   if (e1%value .ne. 33) call abort ()
   if (e2%value .ne. 44) call abort ()
   if (e3%value .ne. 55) call abort ()
   if (r1%value .ne. 11) call abort ()
   if (r2%value .ne. 22) call abort ()

end 

subroutine associated_2 ()
   integer, pointer :: xp(:, :)
   integer, target  :: x(10, 10)
   integer, target  :: y(100, 100)
   interface
      subroutine sub1 (a, ap)
         integer, pointer :: ap(:, :)
         integer, target  :: a(10, 1)
      end
   endinterface

   xp => y
   if (.not. associated (xp)) call abort ()
   call sub1 (x, xp)
   if (associated (xp, y)) call abort ()
   if (.not. associated (xp, x)) call abort ()
end