Commit | Line | Data |
---|---|---|
ed3ef339 DE |
1 | # Copyright (C) 2008-2014 Free Software Foundation, Inc. |
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 exposing values to Guile. | |
18 | ||
19 | load_lib gdb-guile.exp | |
20 | ||
21 | standard_testfile | |
22 | ||
23 | # Build inferior to language specification. | |
24 | # LANG is one of "c" or "c++". | |
25 | proc build_inferior {exefile lang} { | |
26 | global srcdir subdir srcfile testfile hex | |
27 | ||
28 | # Use different names for .o files based on the language. | |
29 | # For Fission, the debug info goes in foo.dwo and we don't want, | |
30 | # for example, a C++ compile to clobber the dwo of a C compile. | |
31 | # ref: http://gcc.gnu.org/wiki/DebugFission | |
32 | switch ${lang} { | |
33 | "c" { set filename ${testfile}.o } | |
34 | "c++" { set filename ${testfile}-cxx.o } | |
35 | } | |
36 | set objfile [standard_output_file $filename] | |
37 | ||
38 | if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${objfile}" object "debug $lang"] != "" | |
39 | || [gdb_compile "${objfile}" "${exefile}" executable "debug $lang"] != "" } { | |
40 | untested "Couldn't compile ${srcfile} in $lang mode" | |
41 | return -1 | |
42 | } | |
43 | return 0 | |
44 | } | |
45 | ||
46 | proc test_value_in_inferior {} { | |
47 | global gdb_prompt | |
48 | global testfile | |
49 | ||
50 | gdb_breakpoint [gdb_get_line_number "break to inspect struct and union"] | |
51 | ||
52 | gdb_continue_to_breakpoint "break to inspect struct and union" | |
53 | ||
54 | # Just get inferior variable s in the value history, available to guile. | |
55 | gdb_test "print s" "= {a = 3, b = 5}" "" | |
56 | ||
57 | gdb_scm_test_silent_cmd "gu (define s (history-ref 0))" "set s" | |
58 | ||
59 | gdb_test "gu (print (value-field s \"a\"))" \ | |
60 | "= 3" "access element inside struct using string name" | |
61 | ||
7a5a839f LC |
62 | # Append value in the value history. |
63 | gdb_scm_test_silent_cmd "gu (define i (history-append! (make-value 42)))" \ | |
64 | "append 42" | |
65 | ||
66 | gdb_test "gu i" "\[0-9\]+" | |
67 | gdb_test "gu (history-ref i)" "#<gdb:value 42>" | |
68 | gdb_test "p \$" "= 42" | |
69 | ||
350e1a76 DE |
70 | # Verify the recorded history value survives a gc. |
71 | gdb_test_no_output "guile (gc)" | |
72 | gdb_test "p \$\$" "= 42" | |
73 | ||
ed3ef339 DE |
74 | # Test dereferencing the argv pointer. |
75 | ||
76 | # Just get inferior variable argv the value history, available to guile. | |
77 | gdb_test "print argv" "= \\(char \\*\\*\\) 0x.*" "" | |
78 | ||
79 | gdb_scm_test_silent_cmd "gu (define argv (history-ref 0))" \ | |
80 | "set argv" | |
81 | gdb_scm_test_silent_cmd "gu (define arg0 (value-dereference argv))" \ | |
82 | "set arg0" | |
83 | ||
84 | # Check that the dereferenced value is sane. | |
85 | if { ! [target_info exists noargs] } { | |
86 | gdb_test "gu (print arg0)" \ | |
87 | "0x.*$testfile\"" "verify dereferenced value" | |
88 | } | |
89 | ||
90 | # Smoke-test value-optimized-out?. | |
91 | gdb_test "gu (print (value-optimized-out? arg0))" \ | |
92 | "= #f" "Test value-optimized-out?" | |
93 | ||
94 | # Test address attribute. | |
95 | gdb_test "gu (print (value-address arg0))" \ | |
96 | "= 0x\[\[:xdigit:\]\]+" "Test address attribute" | |
97 | # Test address attribute is #f in a non-addressable value. | |
98 | gdb_test "gu (print (value-address (make-value 42)))" \ | |
99 | "= #f" "Test address attribute in non-addressable value" | |
100 | ||
101 | # Test displaying a variable that is temporarily at a bad address. | |
102 | # But if we can examine what's at memory address 0, then we'll also be | |
103 | # able to display it without error. Don't run the test in that case. | |
104 | set can_read_0 0 | |
105 | gdb_test_multiple "x 0" "memory at address 0" { | |
106 | -re "0x0:\[ \t\]*Cannot access memory at address 0x0\r\n$gdb_prompt $" { } | |
107 | -re "0x0:\[ \t\]*Error accessing memory address 0x0\r\n$gdb_prompt $" { } | |
108 | -re "\r\n$gdb_prompt $" { | |
109 | set can_read_0 1 | |
110 | } | |
111 | } | |
112 | ||
113 | # Test memory error. | |
114 | set test "parse_and_eval with memory error" | |
115 | if {$can_read_0} { | |
116 | untested $test | |
117 | } else { | |
118 | gdb_test "gu (print (parse-and-eval \"*(int*)0\"))" \ | |
119 | "ERROR: Cannot access memory at address 0x0.*" $test | |
120 | } | |
121 | ||
122 | # Test Guile lazy value handling | |
123 | set test "memory error and lazy values" | |
124 | if {$can_read_0} { | |
125 | untested $test | |
126 | } else { | |
127 | gdb_test_no_output "gu (define inval (parse-and-eval \"*(int*)0\"))" | |
128 | gdb_test "gu (print (value-lazy? inval))" \ | |
129 | "#t" | |
130 | gdb_test "gu (define inval2 (value-add inval 1))" \ | |
131 | "ERROR: Cannot access memory at address 0x0.*" $test | |
132 | gdb_test "gu (value-fetch-lazy! inval))" \ | |
133 | "ERROR: Cannot access memory at address 0x0.*" $test | |
134 | } | |
135 | gdb_test_no_output "gu (define argc-lazy (parse-and-eval \"argc\"))" | |
136 | gdb_test_no_output "gu (define argc-notlazy (parse-and-eval \"argc\"))" | |
137 | gdb_test_no_output "gu (value-fetch-lazy! argc-notlazy)" | |
138 | gdb_test "gu (print (value-lazy? argc-lazy))" "= #t" | |
139 | gdb_test "gu (print (value-lazy? argc-notlazy))" "= #f" | |
140 | gdb_test "print argc" "= 1" "sanity check argc" | |
141 | gdb_test "gu (print (value-lazy? argc-lazy))" "= #t" | |
142 | gdb_test_no_output "set argc=2" | |
143 | gdb_test "gu (print argc-notlazy)" "= 1" | |
144 | gdb_test "gu (print argc-lazy)" "= 2" | |
145 | gdb_test "gu (print (value-lazy? argc-lazy))" "= #f" | |
146 | ||
147 | # Test string fetches, both partial and whole. | |
148 | gdb_test "print st" "\"divide et impera\"" | |
149 | gdb_scm_test_silent_cmd "gu (define st (history-ref 0))" \ | |
150 | "inf: get st value from history" | |
151 | gdb_test "gu (print (value->string st))" \ | |
152 | "= divide et impera" "Test string with no length" | |
153 | gdb_test "gu (print (value->string st #:length -1))" \ | |
154 | "= divide et impera" "Test string (length = -1) is all of the string" | |
155 | gdb_test "gu (print (value->string st #:length 6))" \ | |
156 | "= divide" | |
157 | gdb_test "gu (print (string-append \"---\" (value->string st #:length 0) \"---\"))" \ | |
158 | "= ------" "Test string (length = 0) is empty" | |
159 | gdb_test "gu (print (string-length (value->string st #:length 0)))" \ | |
160 | "= 0" "Test length is 0" | |
161 | ||
162 | # Fetch a string that has embedded nulls. | |
163 | gdb_test "print nullst" "\"divide\\\\000et\\\\000impera\".*" | |
164 | gdb_scm_test_silent_cmd "gu (define nullst (history-ref 0))" \ | |
165 | "inf: get nullst value from history" | |
166 | gdb_test "gu (print (value->string nullst))" \ | |
167 | "divide" "Test string to first null" | |
168 | gdb_scm_test_silent_cmd "gu (set! nullst (value->string nullst #:length 9))" \ | |
169 | "get string beyond null" | |
170 | gdb_test "gu (print nullst)" \ | |
171 | "= divide\\\\000et" | |
172 | } | |
173 | ||
174 | proc test_strings {} { | |
175 | gdb_test "gu (make-value \"test\")" "#<gdb:value \"test\">" "make string" | |
176 | ||
177 | # Test string conversion errors. | |
178 | set save_charset [get_target_charset] | |
179 | gdb_test_no_output "set target-charset UTF-8" | |
180 | ||
181 | gdb_test_no_output "gu (set-port-conversion-strategy! #f 'error)" | |
182 | gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\"))" \ | |
183 | "ERROR.*decoding-error.*" \ | |
184 | "value->string with default #:errors = 'error" | |
185 | ||
186 | # There is no 'escape strategy for C->SCM string conversions, but it's | |
187 | # still a legitimate value for %default-port-conversion-strategy. | |
188 | # GDB handles this by, umm, substituting 'substitute. | |
189 | # Use this case to also handle "#:errors #f" which explicitly says | |
190 | # "use %default-port-conversion-strategy". | |
191 | gdb_test_no_output "gu (set-port-conversion-strategy! #f 'escape)" | |
192 | gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors #f))" \ | |
193 | "= \[?\]{3}" "value->string with default #:errors = 'escape" | |
194 | ||
195 | # This is last in the default conversion tests so that | |
196 | # %default-port-conversion-strategy ends up with the default value. | |
197 | gdb_test_no_output "gu (set-port-conversion-strategy! #f 'substitute)" | |
198 | gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\"))" \ | |
199 | "= \[?\]{3}" "value->string with default #:errors = 'substitute" | |
200 | ||
201 | gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors 'error))" \ | |
202 | "ERROR.*decoding-error.*" "value->string #:errors 'error" | |
203 | gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors 'substitute))" \ | |
204 | "= \[?\]{3}" "value->string #:errors 'substitute" | |
205 | gdb_test "gu (print (value->string (make-value \"abc\") #:errors \"foo\"))" \ | |
206 | "ERROR.*invalid error kind.*" "bad value for #:errors" | |
207 | ||
208 | gdb_test_no_output "set target-charset $save_charset" \ | |
209 | "restore target-charset" | |
210 | } | |
211 | ||
212 | proc test_lazy_strings {} { | |
213 | global hex | |
214 | ||
215 | gdb_test "print sptr" "\"pointer\"" | |
216 | gdb_scm_test_silent_cmd "gu (define sptr (history-ref 0))" \ | |
217 | "lazy strings: get sptr value from history" | |
218 | ||
219 | gdb_scm_test_silent_cmd "gu (define lstr (value->lazy-string sptr))" \ | |
220 | "Aquire lazy string" | |
221 | gdb_test "gu (print (lazy-string-type lstr))" \ | |
222 | "= const char \*." "Test lazy-string type name equality" | |
223 | gdb_test "gu (print (value-type sptr))" \ | |
224 | "= const char \*." "Test string type name equality" | |
225 | gdb_test "print sn" "0x0" | |
226 | gdb_scm_test_silent_cmd "gu (define snptr (history-ref 0))" \ | |
227 | "lazy strings: get snptr value from history" | |
228 | gdb_test "gu (define snstr (value->lazy-string snptr #:length 5))" \ | |
229 | ".*cannot create a lazy string with address.*" "Test lazy string" | |
230 | gdb_scm_test_silent_cmd "gu (define snstr (value->lazy-string snptr #:length 0))" \ | |
231 | "Successfully create a lazy string" | |
232 | gdb_test "gu (print (lazy-string-length snstr))" \ | |
233 | "= 0" "Test lazy string length" | |
234 | gdb_test "gu (print (lazy-string-address snstr))" \ | |
235 | "= 0" "Test lazy string address" | |
236 | } | |
237 | ||
238 | proc test_inferior_function_call {} { | |
239 | global gdb_prompt hex decimal | |
240 | ||
241 | # Correct inferior call without arguments. | |
242 | gdb_test "p/x fp1" "= $hex.*" | |
243 | gdb_scm_test_silent_cmd "gu (define fp1 (history-ref 0))" \ | |
244 | "get fp1 value from history" | |
245 | gdb_scm_test_silent_cmd "gu (set! fp1 (value-dereference fp1))" \ | |
246 | "dereference fp1" | |
247 | gdb_test "gu (print (value-call fp1 '()))" \ | |
248 | "= void" | |
249 | ||
250 | # Correct inferior call with arguments. | |
251 | gdb_test "p/x fp2" "= $hex.*" | |
252 | gdb_scm_test_silent_cmd "gu (define fp2 (history-ref 0))" \ | |
253 | "get fp2 value from history" | |
254 | gdb_scm_test_silent_cmd "gu (set! fp2 (value-dereference fp2))" \ | |
255 | "dereference fp2" | |
256 | gdb_test "gu (print (value-call fp2 (list 10 20)))" \ | |
257 | "= 30" | |
258 | ||
259 | # Incorrect to call an int value. | |
260 | gdb_test "p i" "= $decimal.*" | |
261 | gdb_scm_test_silent_cmd "gu (define i (history-ref 0))" \ | |
262 | "inf call: get i value from history" | |
263 | gdb_test "gu (print (value-call i '()))" \ | |
264 | "ERROR: .*: Wrong type argument in position 1 \\(expecting function \\(value of TYPE_CODE_FUNC\\)\\): .*" | |
265 | ||
266 | # Incorrect number of arguments. | |
267 | gdb_test "p/x fp2" "= $hex.*" | |
268 | gdb_scm_test_silent_cmd "gu (define fp3 (history-ref 0))" \ | |
269 | "get fp3 value from history" | |
270 | gdb_scm_test_silent_cmd "gu (set! fp3 (value-dereference fp3))" \ | |
271 | "dereference fp3" | |
272 | gdb_test "gu (print (value-call fp3 (list 10)))" \ | |
273 | "ERROR: Too few arguments in function call.*" | |
274 | } | |
275 | ||
276 | proc test_value_after_death {} { | |
277 | # Construct a type while the inferior is still running. | |
278 | gdb_scm_test_silent_cmd "gu (define ptrtype (lookup-type \"PTR\"))" \ | |
279 | "create PTR type" | |
280 | ||
281 | # Kill the inferior and remove the symbols. | |
282 | gdb_test "kill" "" "kill the inferior" \ | |
283 | "Kill the program being debugged. .y or n. $" \ | |
284 | "y" | |
285 | gdb_test "file" "" "Discard the symbols" \ | |
286 | "Discard symbol table from.*y or n. $" \ | |
287 | "y" | |
288 | ||
289 | # Now create a value using that type. Relies on arg0, created by | |
290 | # test_value_in_inferior. | |
291 | gdb_scm_test_silent_cmd "gu (define castval (value-cast arg0 (type-pointer ptrtype)))" \ | |
292 | "cast arg0 to PTR" | |
293 | ||
294 | # Make sure the type is deleted. | |
295 | gdb_scm_test_silent_cmd "gu (set! ptrtype #f)" \ | |
296 | "delete PTR type" | |
297 | ||
298 | # Now see if the value's type is still valid. | |
299 | gdb_test "gu (print (value-type castval))" \ | |
300 | "= PTR ." "print value's type" | |
301 | } | |
302 | ||
303 | # Regression test for invalid subscript operations. The bug was that | |
304 | # the type of the value was not being checked before allowing a | |
305 | # subscript operation to proceed. | |
306 | ||
307 | proc test_subscript_regression {exefile lang} { | |
308 | # Start with a fresh gdb. | |
309 | clean_restart ${exefile} | |
310 | ||
311 | if ![gdb_guile_runto_main ] { | |
312 | fail "Can't run to main" | |
313 | return | |
314 | } | |
315 | ||
316 | if {$lang == "c++"} { | |
317 | gdb_breakpoint [gdb_get_line_number "break to inspect pointer by reference"] | |
318 | gdb_continue_to_breakpoint "break to inspect pointer by reference" | |
319 | ||
320 | gdb_scm_test_silent_cmd "print rptr_int" \ | |
321 | "Obtain address" | |
322 | gdb_scm_test_silent_cmd "gu (define rptr (history-ref 0))" \ | |
323 | "set rptr" | |
324 | gdb_test "gu (print (value-subscript rptr 0))" \ | |
325 | "= 2" "Check pointer passed as reference" | |
326 | ||
327 | # Just the most basic test of dynamic_cast -- it is checked in | |
328 | # the C++ tests. | |
329 | gdb_test "gu (print (value->bool (value-dynamic-cast (parse-and-eval \"base\") (type-pointer (lookup-type \"Derived\")))))" \ | |
330 | "= #t" | |
331 | ||
332 | # Likewise. | |
333 | gdb_test "gu (print (value-dynamic-type (parse-and-eval \"base\")))" \ | |
334 | "= Derived \[*\]" | |
335 | # A static type case. | |
336 | gdb_test "gu (print (value-dynamic-type (parse-and-eval \"5\")))" \ | |
337 | "= int" | |
338 | } | |
339 | ||
340 | gdb_breakpoint [gdb_get_line_number "break to inspect struct and union"] | |
341 | gdb_continue_to_breakpoint "break to inspect struct and union" | |
342 | ||
343 | gdb_scm_test_silent_cmd "gu (define intv (make-value 1))" \ | |
344 | "Create int value for subscript test" | |
345 | gdb_scm_test_silent_cmd "gu (define stringv (make-value \"foo\"))" \ | |
346 | "Create string value for subscript test" | |
347 | ||
348 | # Try to access an int with a subscript. This should fail. | |
349 | gdb_test "gu (print intv)" \ | |
350 | "= 1" "Baseline print of an int Guile value" | |
351 | gdb_test "gu (print (value-subscript intv 0))" \ | |
352 | "ERROR: Cannot subscript requested type.*" \ | |
353 | "Attempt to access an integer with a subscript" | |
354 | ||
355 | # Try to access a string with a subscript. This should pass. | |
356 | gdb_test "gu (print stringv)" \ | |
357 | "= \"foo\"" "Baseline print of a string Guile value" | |
358 | gdb_test "gu (print (value-subscript stringv 0))" \ | |
359 | "= 102 'f'" "Attempt to access a string with a subscript" | |
360 | ||
361 | # Try to access an int array via a pointer with a subscript. | |
362 | # This should pass. | |
363 | gdb_scm_test_silent_cmd "print p" "Build pointer to array" | |
364 | gdb_scm_test_silent_cmd "gu (define pointer (history-ref 0))" "set pointer" | |
365 | gdb_test "gu (print (value-subscript pointer 0))" \ | |
366 | "= 1" "Access array via pointer with int subscript" | |
367 | gdb_test "gu (print (value-subscript pointer intv))" \ | |
368 | "= 2" "Access array via pointer with value subscript" | |
369 | ||
370 | # Try to access a single dimension array with a subscript to the | |
371 | # result. This should fail. | |
372 | gdb_test "gu (print (value-subscript (value-subscript pointer intv) 0))" \ | |
373 | "ERROR: Cannot subscript requested type.*" \ | |
374 | "Attempt to access an integer with a subscript 2" | |
375 | ||
376 | # Lastly, test subscript access to an array with multiple | |
377 | # dimensions. This should pass. | |
378 | gdb_scm_test_silent_cmd "print {\"fu \",\"foo\",\"bar\"}" "Build array" | |
379 | gdb_scm_test_silent_cmd "gu (define marray (history-ref 0))" "" | |
380 | gdb_test "gu (print (value-subscript (value-subscript marray 1) 2))" \ | |
381 | "o." "Test multiple subscript" | |
382 | } | |
383 | ||
384 | # A few tests of gdb:parse-and-eval. | |
385 | ||
386 | proc test_parse_and_eval {} { | |
387 | gdb_test "gu (print (parse-and-eval \"23\"))" \ | |
388 | "= 23" "parse-and-eval constant test" | |
389 | gdb_test "gu (print (parse-and-eval \"5 + 7\"))" \ | |
390 | "= 12" "parse-and-eval simple expression test" | |
391 | gdb_test "gu (raw-print (parse-and-eval \"5 + 7\"))" \ | |
392 | "#<gdb:value 12>" "parse-and-eval type test" | |
393 | } | |
394 | ||
395 | # Test that values are hashable. | |
396 | # N.B.: While smobs are hashable, the hash is really non-existent, | |
397 | # they all get hashed to the same value. Guile may provide a hash function | |
398 | # for smobs in a future release. In the meantime one should use a custom | |
399 | # hash table that uses gdb:hash-gsmob. | |
400 | ||
401 | proc test_value_hash {} { | |
402 | gdb_test_multiline "Simple Guile value dictionary" \ | |
403 | "guile" "" \ | |
404 | "(define one (make-value 1))" "" \ | |
405 | "(define two (make-value 2))" "" \ | |
406 | "(define three (make-value 3))" "" \ | |
407 | "(define vdict (make-hash-table 5))" "" \ | |
408 | "(hash-set! vdict one \"one str\")" "" \ | |
409 | "(hash-set! vdict two \"two str\")" "" \ | |
410 | "(hash-set! vdict three \"three str\")" "" \ | |
411 | "end" | |
412 | gdb_test "gu (print (hash-ref vdict one))" \ | |
413 | "one str" "Test dictionary hash 1" | |
414 | gdb_test "gu (print (hash-ref vdict two))" \ | |
415 | "two str" "Test dictionary hash 2" | |
416 | gdb_test "gu (print (hash-ref vdict three))" \ | |
417 | "three str" "Test dictionary hash 3" | |
418 | } | |
419 | ||
420 | # Build C version of executable. C++ is built later. | |
421 | if { [build_inferior "${binfile}" "c"] < 0 } { | |
422 | return | |
423 | } | |
424 | ||
425 | # Start with a fresh gdb. | |
426 | clean_restart ${binfile} | |
427 | ||
428 | # Skip all tests if Guile scripting is not enabled. | |
429 | if { [skip_guile_tests] } { continue } | |
430 | ||
431 | gdb_install_guile_utils | |
432 | gdb_install_guile_module | |
433 | ||
434 | test_parse_and_eval | |
435 | test_value_hash | |
436 | ||
437 | # The following tests require execution. | |
438 | ||
439 | if ![gdb_guile_runto_main] { | |
440 | fail "Can't run to main" | |
441 | return | |
442 | } | |
443 | ||
444 | test_value_in_inferior | |
445 | test_inferior_function_call | |
446 | test_strings | |
447 | test_lazy_strings | |
448 | test_value_after_death | |
449 | ||
450 | # Test either C or C++ values. | |
451 | ||
452 | test_subscript_regression "${binfile}" "c" | |
453 | ||
454 | if ![skip_cplus_tests] { | |
455 | if { [build_inferior "${binfile}-cxx" "c++"] < 0 } { | |
456 | return | |
457 | } | |
458 | with_test_prefix "c++" { | |
459 | test_subscript_regression "${binfile}-cxx" "c++" | |
460 | } | |
461 | } |