Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/gfortran.dg/assumed_rank_9.f90 @ 111:04ced10e8804
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 |