|
111
|
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)
|
|
131
|
38 if (j /= 2) STOP 1
|
|
111
|
39
|
|
|
40 j = 0
|
|
|
41 call gc(null())
|
|
|
42 call gc(y)
|
|
|
43 call gc(yac)
|
|
|
44 deallocate (yac)
|
|
|
45 call gc(yac)
|
|
131
|
46 if (j /= 2) STOP 2
|
|
111
|
47
|
|
|
48 j = 0
|
|
|
49 call hc(yac)
|
|
|
50 allocate (yac)
|
|
|
51 yac%i = 489
|
|
|
52 call hc(yac)
|
|
131
|
53 if (j /= 1) STOP 3
|
|
111
|
54
|
|
|
55 j = 0
|
|
|
56 call ft()
|
|
|
57 call ft(null())
|
|
|
58 call ft(y)
|
|
|
59 call ft(yac)
|
|
131
|
60 if (j /= 2) STOP 4
|
|
111
|
61
|
|
|
62 j = 0
|
|
|
63 call gt(null())
|
|
|
64 call gt(y)
|
|
|
65 call gt(yac)
|
|
|
66 deallocate (yac)
|
|
|
67 call gt(yac)
|
|
131
|
68 if (j /= 2) STOP 5
|
|
111
|
69
|
|
|
70 j = 0
|
|
|
71 call ht(yac)
|
|
|
72 allocate (yac)
|
|
|
73 yac%i = 489
|
|
|
74 call ht(yac)
|
|
131
|
75 if (j /= 1) STOP 6
|
|
111
|
76
|
|
|
77 contains
|
|
|
78
|
|
|
79 subroutine fc (x)
|
|
|
80 class(t), optional :: x(..)
|
|
|
81
|
|
|
82 if (.not. present (x)) return
|
|
131
|
83 if (.not. SAME_TYPE_AS (x, yac)) STOP 7
|
|
|
84 if (rank (x) /= 0) STOP 1
|
|
111
|
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
|
|
131
|
93 if (.not. SAME_TYPE_AS (x, yac)) STOP 8
|
|
|
94 if (rank (x) /= 0) STOP 9
|
|
111
|
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
|
|
131
|
103 if (.not. SAME_TYPE_AS (x, yac)) STOP 10
|
|
|
104 if (rank (x) /= 0) STOP 2
|
|
111
|
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
|
|
131
|
113 if (.not. SAME_TYPE_AS (x, yac)) STOP 11
|
|
|
114 if (rank (x) /= 0) STOP 3
|
|
111
|
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
|
|
131
|
123 if (.not. SAME_TYPE_AS (x, yac)) STOP 12
|
|
|
124 if (rank (x) /= 0) STOP 13
|
|
111
|
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
|
|
131
|
133 if (.not. SAME_TYPE_AS (x, yac)) STOP 14
|
|
|
134 if (rank (x) /= 0) STOP 4
|
|
111
|
135 call check2 (x)
|
|
|
136 j = j + 1
|
|
|
137 end subroutine
|
|
|
138
|
|
|
139 end program main
|
