URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [execute/] [intrinsic_associated.f90] - Blame information for rev 843

Go to most recent revision | Details | Compare with Previous | View Log


! 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
 

Line No.	Rev	Author	Line
1	303	jeremybenn	`! 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

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [execute/] [intrinsic_associated.f90] - Blame information for rev 843