]>
Commit | Line | Data |
---|---|---|
1d506c26 | 1 | # Copyright (C) 2009-2024 Free Software Foundation, Inc. |
ed3ef339 DE |
2 | |
3 | # This program is free software; you can redistribute it and/or modify | |
4 | # it under the terms of the GNU General Public License as published by | |
5 | # the Free Software Foundation; either version 3 of the License, or | |
6 | # (at your option) any later version. | |
7 | # | |
8 | # This program is distributed in the hope that it will be useful, | |
9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | # GNU General Public License for more details. | |
12 | # | |
13 | # You should have received a copy of the GNU General Public License | |
14 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | |
15 | ||
16 | # This file is part of the GDB testsuite. | |
17 | # It tests the mechanism of exposing types to Guile. | |
18 | ||
19 | load_lib gdb-guile.exp | |
20 | ||
21 | standard_testfile | |
22 | ||
ed3ef339 DE |
23 | # Build inferior to language specification. |
24 | ||
25 | proc build_inferior {exefile lang} { | |
26 | global srcdir subdir srcfile | |
27 | ||
28 | if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } { | |
84c93cd5 | 29 | untested "failed to compile in $lang mode" |
ed3ef339 DE |
30 | return -1 |
31 | } | |
32 | return 0 | |
33 | } | |
34 | ||
35 | # Restart GDB. | |
36 | # The result is the same as gdb_guile_runto_main. | |
37 | ||
38 | proc restart_gdb {exefile} { | |
39 | global srcdir subdir | |
40 | ||
888438e2 | 41 | clean_restart $exefile |
ed3ef339 | 42 | |
e71b6502 | 43 | if { ![allow_guile_tests] } { |
ed3ef339 DE |
44 | return 0 |
45 | } | |
46 | ||
47 | if ![gdb_guile_runto_main] { | |
48 | return 0 | |
49 | } | |
50 | gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \ | |
62f2f198 | 51 | "load iterator module" 0 |
ed3ef339 DE |
52 | |
53 | return 1 | |
54 | } | |
55 | ||
56 | # Set breakpoint and run to that breakpoint. | |
57 | ||
58 | proc runto_bp {bp} { | |
59 | gdb_breakpoint [gdb_get_line_number $bp] | |
60 | gdb_continue_to_breakpoint $bp | |
61 | } | |
62 | ||
63 | proc test_fields {lang} { | |
64 | with_test_prefix "test_fields" { | |
65 | global gdb_prompt | |
66 | ||
67 | # fields of a typedef should still return the underlying field list | |
68 | gdb_test "guile (print (length (type-fields (value-type (parse-and-eval \"ts\")))))" \ | |
69 | "= 2" "$lang typedef field list" | |
70 | ||
71 | if {$lang == "c++"} { | |
72 | # Test usage with a class. | |
73 | gdb_scm_test_silent_cmd "print c" "print value (c)" | |
74 | gdb_scm_test_silent_cmd "guile (define c (history-ref 0))" \ | |
75 | "get value (c) from history" | |
76 | gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type c)))" \ | |
77 | "get fields from c type" | |
78 | gdb_test "guile (print (length fields))" \ | |
79 | "= 2" "check number of fields of c" | |
80 | gdb_test "guile (print (field-name (car fields)))" \ | |
81 | "= c" "check class field c name" | |
82 | gdb_test "guile (print (field-name (cadr fields)))" \ | |
83 | "= d" "check class field d name" | |
84 | } | |
85 | ||
86 | # Test normal fields usage in structs. | |
87 | gdb_scm_test_silent_cmd "print st" "print value (st)" | |
88 | gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \ | |
89 | "get value (st) from history" | |
90 | gdb_scm_test_silent_cmd "guile (define st-type (value-type st))" \ | |
91 | "get st-type" | |
92 | gdb_scm_test_silent_cmd "guile (define fields (type-fields st-type))" \ | |
93 | "get fields from st.type" | |
94 | gdb_test "guile (print (length fields))" \ | |
95 | "= 2" "check number of fields (st)" | |
96 | gdb_test "guile (print (field-name (car fields)))" \ | |
97 | "= a" "check structure field a name" | |
98 | gdb_test "guile (print (field-name (cadr fields)))" \ | |
99 | "= b" "check structure field b name" | |
100 | gdb_test "guile (print (field-name (type-field st-type \"a\")))" \ | |
101 | "= a" "check fields lookup by name" | |
102 | ||
103 | # Test has-field? | |
104 | gdb_test "guile (print (type-has-field? st-type \"b\"))" \ | |
105 | "= #t" "check existent field" | |
106 | gdb_test "guile (print (type-has-field? st-type \"nosuch\"))" \ | |
107 | "= #f" "check non-existent field" | |
108 | ||
109 | # Test Guile mapping behavior of gdb:type for structs/classes. | |
110 | gdb_test "guile (print (type-num-fields (value-type st)))" \ | |
111 | "= 2" "check number of fields (st) with type-num-fields" | |
112 | gdb_scm_test_silent_cmd "guile (define fi (make-field-iterator st-type))" \ | |
113 | "create field iterator" | |
114 | gdb_test "guile (print (iterator-map field-bitpos fi))" \ | |
115 | "= \\(0 32\\)" "check field iterator" | |
116 | ||
117 | # Test rejection of mapping operations on scalar types. | |
118 | gdb_test "guile (print (make-field-iterator (field-type (type-field st-type \"a\"))))" \ | |
119 | "ERROR: .*: Out of range: type is not a structure, union, or enum type in position 1: .*" \ | |
120 | "check field iterator on bad type" | |
121 | ||
122 | # Test type-array. | |
123 | gdb_scm_test_silent_cmd "print ar" "print value (ar)" | |
124 | gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \ | |
125 | "get value (ar) from history" | |
126 | gdb_scm_test_silent_cmd "guile (define ar0 (value-subscript ar 0))" \ | |
127 | "define ar0" | |
128 | gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 1)))" \ | |
129 | "= \\{1, 2\\}" "cast to array with one argument" | |
130 | gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 0 1)))" \ | |
131 | "= \\{1, 2\\}" "cast to array with two arguments" | |
132 | ||
133 | # Test type-vector. | |
134 | # Note: vectors cast differently than arrays. Here ar[0] is replicated | |
135 | # for the size of the vector. | |
136 | gdb_scm_test_silent_cmd "print vec_data_1" "print value (vec_data_1)" | |
137 | gdb_scm_test_silent_cmd "guile (define vec_data_1 (history-ref 0))" \ | |
138 | "get value (vec_data_1) from history" | |
139 | ||
140 | gdb_scm_test_silent_cmd "print vec_data_2" "print value (vec_data_2)" | |
141 | gdb_scm_test_silent_cmd "guile (define vec_data_2 (history-ref 0))" \ | |
142 | "get value (vec_data_2) from history" | |
143 | ||
144 | gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \ | |
145 | "set vec1" | |
146 | gdb_test "guile (print vec1)" \ | |
147 | "= \\{1, 1\\}" "cast to vector with one argument" | |
148 | gdb_scm_test_silent_cmd "guile (define vec2 (value-cast vec_data_1 (type-vector (value-type ar0) 0 1)))" \ | |
149 | "set vec2" | |
150 | gdb_test "guile (print vec2)" \ | |
151 | "= \\{1, 1\\}" "cast to vector with two arguments" | |
152 | gdb_test "guile (print (value=? vec1 vec2))" \ | |
153 | "= #t" | |
154 | gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \ | |
155 | "set vec3" | |
156 | gdb_test "guile (print (value=? vec1 vec3))" \ | |
157 | "= #f" | |
158 | } | |
159 | } | |
160 | ||
161 | proc test_equality {lang} { | |
162 | with_test_prefix "test_equality" { | |
163 | gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \ | |
164 | "get st" | |
165 | gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \ | |
166 | "get ar" | |
167 | gdb_test "guile (print (eq? (value-type st) (value-type st)))" \ | |
168 | "= #t" "test type eq? on equal types" | |
169 | gdb_test "guile (print (eq? (value-type st) (value-type ar)))" \ | |
170 | "= #f" "test type eq? on not-equal types" | |
171 | gdb_test "guile (print (equal? (value-type st) (value-type st)))" \ | |
62f2f198 | 172 | "= #t" "test type equal? on equal types" |
ed3ef339 | 173 | gdb_test "guile (print (equal? (value-type st) (value-type ar)))" \ |
62f2f198 | 174 | "= #f" "test type equal? on not-equal types" |
ed3ef339 DE |
175 | |
176 | if {$lang == "c++"} { | |
177 | gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \ | |
178 | "get c" | |
179 | gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \ | |
180 | "get d" | |
181 | gdb_test "guile (print (eq? (value-type c) (field-type (car (type-fields (value-type d))))))" \ | |
182 | "= #t" "test c++ type eq? on equal types" | |
183 | gdb_test "guile (print (eq? (value-type c) (value-type d)))" \ | |
184 | "= #f" "test c++ type eq? on not-equal types" | |
185 | gdb_test "guile (print (equal? (value-type c) (field-type (car (type-fields (value-type d))))))" \ | |
186 | "= #t" "test c++ type equal? on equal types" | |
187 | gdb_test "guile (print (equal? (value-type c) (value-type d)))" \ | |
188 | "= #f" "test c++ type equal? on not-equal types" | |
189 | } | |
190 | } | |
191 | } | |
192 | ||
193 | proc test_enums {} { | |
194 | with_test_prefix "test_enum" { | |
195 | gdb_scm_test_silent_cmd "print e" "print value (e)" | |
196 | gdb_scm_test_silent_cmd "guile (define e (history-ref 0))" \ | |
197 | "get value (e) from history" | |
198 | gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type e)))" \ | |
199 | "extract type fields from e" | |
200 | gdb_test "guile (print (length fields))" \ | |
201 | "= 3" "check the number of enum fields" | |
202 | gdb_test "guile (print (field-name (car fields)))" \ | |
203 | "= v1" "check enum field\[0\] name" | |
204 | gdb_test "guile (print (field-name (cadr fields)))" \ | |
205 | "= v2" "check enum field\[1\]name" | |
206 | ||
207 | # Ditto but by mapping operations. | |
208 | gdb_test "guile (print (type-num-fields (value-type e)))" \ | |
209 | "= 3" "check the number of enum values" | |
210 | gdb_test "guile (print (field-name (type-field (value-type e) \"v1\")))" \ | |
211 | "= v1" "check enum field lookup by name (v1)" | |
212 | gdb_test "guile (print (field-name (type-field (value-type e) \"v3\")))" \ | |
213 | "= v3" "check enum field lookup by name (v3)" | |
214 | gdb_test "guile (print (iterator-map field-enumval (make-field-iterator (value-type e))))" \ | |
215 | "\\(0 1 2\\)" "check enum fields iteration" | |
216 | } | |
217 | } | |
218 | ||
219 | proc test_base_class {} { | |
220 | with_test_prefix "test_base_class" { | |
221 | gdb_scm_test_silent_cmd "print d" "print value (d)" | |
222 | gdb_scm_test_silent_cmd "guile (define d (history-ref 0))" \ | |
223 | "get value (d) from history" | |
224 | gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type d)))" \ | |
225 | "extract type fields from d" | |
226 | gdb_test "guile (print (length fields))" \ | |
227 | "= 3" "check the number of fields" | |
228 | gdb_test "guile (print (field-baseclass? (car fields)))" \ | |
229 | "= #t" "check base class (fields\[0\])" | |
230 | gdb_test "guile (print (field-baseclass? (cadr fields)))" \ | |
231 | "= #f" "check base class (fields\[1\])" | |
232 | } | |
233 | } | |
234 | ||
235 | proc test_range {} { | |
236 | with_test_prefix "test_range" { | |
237 | with_test_prefix "on ranged value" { | |
238 | # Test a valid range request. | |
239 | gdb_scm_test_silent_cmd "print ar" "print value (ar)" | |
240 | gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \ | |
241 | "get value (ar) from history" | |
242 | gdb_test "guile (print (length (type-range (value-type ar))))" \ | |
243 | "= 2" "check correct tuple length" | |
244 | gdb_test "guile (print (type-range (value-type ar)))" \ | |
245 | "= \\(0 1\\)" "check range" | |
246 | } | |
247 | ||
248 | with_test_prefix "on unranged value" { | |
249 | # Test where a range does not exist. | |
250 | gdb_scm_test_silent_cmd "print st" "print value (st)" | |
251 | gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \ | |
252 | "get value (st) from history" | |
253 | gdb_test "guile (print (type-range (value-type st)))" \ | |
254 | "ERROR: .*: Wrong type argument in position 1 \\(expecting ranged type\\): .*" \ | |
255 | "check range for non ranged type" | |
256 | } | |
e25d6d93 SM |
257 | |
258 | with_test_prefix "on flexible array member" { | |
259 | gdb_scm_test_silent_cmd "print f" "print value (f)" | |
260 | gdb_scm_test_silent_cmd "guile (define f (history-ref 0))" \ | |
261 | "get value (f) from history" | |
262 | gdb_test "guile (print (type-range (field-type (type-field (value-type (value-dereference f)) \"items\"))))" \ | |
22589c49 | 263 | "= \\(0 (0|-1)\\)" |
e25d6d93 SM |
264 | gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 0))" \ |
265 | "= 111" | |
266 | gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 1))" \ | |
267 | "= 222" | |
268 | } | |
ed3ef339 DE |
269 | } |
270 | } | |
271 | ||
272 | # Perform C Tests. | |
273 | ||
274 | if { [build_inferior "${binfile}" "c"] < 0 } { | |
275 | return | |
276 | } | |
277 | if ![restart_gdb "${binfile}"] { | |
278 | return | |
279 | } | |
280 | ||
281 | with_test_prefix "lang_c" { | |
282 | runto_bp "break to inspect struct and array." | |
283 | test_fields "c" | |
284 | test_equality "c" | |
285 | test_enums | |
286 | } | |
287 | ||
288 | # Perform C++ Tests. | |
289 | ||
290 | if { [build_inferior "${binfile}-cxx" "c++"] < 0 } { | |
291 | return | |
292 | } | |
293 | if ![restart_gdb "${binfile}-cxx"] { | |
294 | return | |
295 | } | |
296 | ||
297 | with_test_prefix "lang_cpp" { | |
298 | runto_bp "break to inspect struct and array." | |
299 | test_fields "c++" | |
300 | test_base_class | |
301 | test_range | |
302 | test_equality "c++" | |
303 | test_enums | |
304 | } |