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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/48820
!
! Test TYPE(*)
!
module mod
use iso_c_binding, only: c_loc, c_ptr, c_bool
implicit none
interface my_c_loc
function my_c_loc1(x) bind(C)
import c_ptr
type(*) :: x
type(c_ptr) :: my_c_loc1
end function
function my_c_loc2(x) bind(C)
import c_ptr
type(*) :: x(*)
type(c_ptr) :: my_c_loc2
end function
end interface my_c_loc
contains
subroutine sub_scalar (arg1, presnt)
type(*), target, optional :: arg1
logical :: presnt
type(c_ptr) :: cpt
if (presnt .neqv. present (arg1)) call abort ()
cpt = c_loc (arg1)
end subroutine sub_scalar
subroutine sub_array_shape (arg2, lbounds, ubounds)
type(*), target :: arg2(:,:)
type(c_ptr) :: cpt
integer :: lbounds(2), ubounds(2)
if (any (lbound(arg2) /= lbounds)) call abort ()
if (any (ubound(arg2) /= ubounds)) call abort ()
if (any (shape(arg2) /= ubounds-lbounds+1)) call abort ()
if (size(arg2) /= product (ubounds-lbounds+1)) call abort ()
if (rank (arg2) /= 2) call abort ()
! if (.not. is_continuous (arg2)) call abort () !<< Not yet implemented
! cpt = c_loc (arg2) ! << FIXME: Valid since TS29113
call sub_array_assumed (arg2)
end subroutine sub_array_shape
subroutine sub_array_assumed (arg3)
type(*), target :: arg3(*)
type(c_ptr) :: cpt
cpt = c_loc (arg3)
end subroutine sub_array_assumed
end module
use mod
use iso_c_binding, only: c_int, c_null_ptr
implicit none
type t1
integer :: a
end type t1
type :: t2
sequence
integer :: b
end type t2
type, bind(C) :: t3
integer(c_int) :: c
end type t3
integer :: scalar_int
real, allocatable :: scalar_real_alloc
character, pointer :: scalar_char_ptr
integer :: array_int(3)
real, allocatable :: array_real_alloc(:,:)
character, pointer :: array_char_ptr(:,:)
type(t1) :: scalar_t1
type(t2), allocatable :: scalar_t2_alloc
type(t3), pointer :: scalar_t3_ptr
type(t1) :: array_t1(4)
type(t2), allocatable :: array_t2_alloc(:,:)
type(t3), pointer :: array_t3_ptr(:,:)
class(t1), allocatable :: scalar_class_t1_alloc
class(t1), pointer :: scalar_class_t1_ptr
class(t1), allocatable :: array_class_t1_alloc(:,:)
class(t1), pointer :: array_class_t1_ptr(:,:)
scalar_char_ptr => null()
scalar_t3_ptr => null()
call sub_scalar (presnt=.false.)
call sub_scalar (scalar_real_alloc, .false.)
call sub_scalar (scalar_char_ptr, .false.)
call sub_scalar (null (), .false.)
call sub_scalar (scalar_t2_alloc, .false.)
call sub_scalar (scalar_t3_ptr, .false.)
allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr)
allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc)
allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2))
allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2))
allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4))
call sub_scalar (scalar_int, .true.)
call sub_scalar (scalar_real_alloc, .true.)
call sub_scalar (scalar_char_ptr, .true.)
call sub_scalar (array_int(2), .true.)
call sub_scalar (array_real_alloc(3,2), .true.)
call sub_scalar (array_char_ptr(0,1), .true.)
call sub_scalar (scalar_t1, .true.)
call sub_scalar (scalar_t2_alloc, .true.)
call sub_scalar (scalar_t3_ptr, .true.)
call sub_scalar (array_t1(2), .true.)
call sub_scalar (array_t2_alloc(3,2), .true.)
call sub_scalar (array_t3_ptr(0,1), .true.)
call sub_scalar (array_class_t1_alloc(2,1), .true.)
call sub_scalar (array_class_t1_ptr(3,3), .true.)
call sub_array_assumed (array_int)
call sub_array_assumed (array_real_alloc)
call sub_array_assumed (array_char_ptr)
call sub_array_assumed (array_t1)
call sub_array_assumed (array_t2_alloc)
call sub_array_assumed (array_t3_ptr)
call sub_array_assumed (array_class_t1_alloc)
call sub_array_assumed (array_class_t1_ptr)
call sub_array_shape (array_real_alloc, [1,1], shape(array_real_alloc))
call sub_array_shape (array_char_ptr, [1,1], shape(array_char_ptr))
call sub_array_shape (array_t2_alloc, [1,1], shape(array_t2_alloc))
call sub_array_shape (array_t3_ptr, [1,1], shape(array_t3_ptr))
call sub_array_shape (array_class_t1_alloc, [1,1], shape(array_class_t1_alloc))
call sub_array_shape (array_class_t1_ptr, [1,1], shape(array_class_t1_ptr))
deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr)
deallocate (array_class_t1_ptr, array_t3_ptr)
end
! { dg-final { scan-tree-dump-times "sub_scalar .0B," 2 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .scalar_real_alloc," 2 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .scalar_char_ptr," 2 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t2_alloc," 2 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t3_ptr" 2 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_int," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_ptr._data.dat" 1 "original" } }a
! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 3 "original" } }
! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } }
! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_real_alloc," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_char_ptr," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t2_alloc," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t3_ptr," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_alloc._data," 1 "original" } }
! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_ptr._data," 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
|
