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