Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/gfortran.dg/assumed_rank_9.f90 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ! { dg-do run }
2 ! { dg-additional-sources assumed_rank_8_c.c }
3 !
4 ! PR fortran/48820
5 !
6 ! Scalars to assumed-rank tests
7 !
8 program main
9 implicit none
10
11 type t
12 integer :: i
13 end type t
14
15 interface
16 subroutine check (x)
17 integer :: x(..)
18 end subroutine check
19 subroutine check2 (x)
20 import t
21 class(t) :: x(..)
22 end subroutine check2
23 end interface
24
25 integer :: j
26
27 type(t), target :: y
28 class(t), allocatable, target :: yac
29
30 y%i = 489
31 allocate (yac)
32 yac%i = 489
33 j = 0
34 call fc()
35 call fc(null())
36 call fc(y)
37 call fc(yac)
38 if (j /= 2) call abort ()
39
40 j = 0
41 call gc(null())
42 call gc(y)
43 call gc(yac)
44 deallocate (yac)
45 call gc(yac)
46 if (j /= 2) call abort ()
47
48 j = 0
49 call hc(yac)
50 allocate (yac)
51 yac%i = 489
52 call hc(yac)
53 if (j /= 1) call abort ()
54
55 j = 0
56 call ft()
57 call ft(null())
58 call ft(y)
59 call ft(yac)
60 if (j /= 2) call abort ()
61
62 j = 0
63 call gt(null())
64 call gt(y)
65 call gt(yac)
66 deallocate (yac)
67 call gt(yac)
68 if (j /= 2) call abort ()
69
70 j = 0
71 call ht(yac)
72 allocate (yac)
73 yac%i = 489
74 call ht(yac)
75 if (j /= 1) call abort ()
76
77 contains
78
79 subroutine fc (x)
80 class(t), optional :: x(..)
81
82 if (.not. present (x)) return
83 if (.not. SAME_TYPE_AS (x, yac)) call abort ()
84 if (rank (x) /= 0) call abort
85 call check2 (x)
86 j = j + 1
87 end subroutine
88
89 subroutine gc (x)
90 class(t), pointer, intent(in) :: x(..)
91
92 if (.not. associated (x)) return
93 if (.not. SAME_TYPE_AS (x, yac)) call abort ()
94 if (rank (x) /= 0) call abort ()
95 call check2 (x)
96 j = j + 1
97 end subroutine
98
99 subroutine hc (x)
100 class(t), allocatable :: x(..)
101
102 if (.not. allocated (x)) return
103 if (.not. SAME_TYPE_AS (x, yac)) call abort ()
104 if (rank (x) /= 0) call abort
105 call check2 (x)
106 j = j + 1
107 end subroutine
108
109 subroutine ft (x)
110 type(t), optional :: x(..)
111
112 if (.not. present (x)) return
113 if (.not. SAME_TYPE_AS (x, yac)) call abort ()
114 if (rank (x) /= 0) call abort
115 call check2 (x)
116 j = j + 1
117 end subroutine
118
119 subroutine gt (x)
120 type(t), pointer, intent(in) :: x(..)
121
122 if (.not. associated (x)) return
123 if (.not. SAME_TYPE_AS (x, yac)) call abort ()
124 if (rank (x) /= 0) call abort ()
125 call check2 (x)
126 j = j + 1
127 end subroutine
128
129 subroutine ht (x)
130 type(t), allocatable :: x(..)
131
132 if (.not. allocated (x)) return
133 if (.not. SAME_TYPE_AS (x, yac)) call abort ()
134 if (rank (x) /= 0) call abort
135 call check2 (x)
136 j = j + 1
137 end subroutine
138
139 end program main