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