Commit | Line | Data |
---|---|---|
ed3ef339 DE |
1 | # Copyright (C) 2010-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 breakpoints to Guile. | |
18 | ||
19 | load_lib gdb-guile.exp | |
20 | ||
21 | standard_testfile | |
22 | ||
23 | if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } { | |
24 | return -1 | |
25 | } | |
26 | ||
27 | # Skip all tests if Guile scripting is not enabled. | |
28 | if { [skip_guile_tests] } { continue } | |
29 | ||
30 | proc test_bkpt_basic { } { | |
31 | global srcfile testfile hex decimal | |
32 | ||
33 | with_test_prefix "test_bkpt_basic" { | |
34 | # Start with a fresh gdb. | |
35 | clean_restart ${testfile} | |
36 | ||
37 | if ![gdb_guile_runto_main] { | |
38 | return | |
39 | } | |
40 | ||
41 | # Initially there should be one breakpoint: main. | |
42 | ||
43 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
44 | "get breakpoint list 1" | |
45 | gdb_test "guile (print (car blist))" \ | |
46 | "<gdb:breakpoint #1 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @main>" \ | |
47 | "check main breakpoint" | |
48 | gdb_test "guile (print (breakpoint-location (car blist)))" \ | |
49 | "main" "check main breakpoint location" | |
50 | ||
51 | set mult_line [gdb_get_line_number "Break at multiply."] | |
52 | gdb_breakpoint ${mult_line} | |
53 | gdb_continue_to_breakpoint "Break at multiply." | |
54 | ||
55 | # Check that the Guile breakpoint code noted the addition of a | |
56 | # breakpoint "behind the scenes". | |
57 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
58 | "get breakpoint list 2" | |
59 | gdb_scm_test_silent_cmd "guile (define mult-bkpt (cadr blist))" \ | |
60 | "get multiply breakpoint" | |
61 | gdb_test "guile (print (length blist))" \ | |
62 | "= 2" "check for two breakpoints" | |
63 | gdb_test "guile (print mult-bkpt)" \ | |
64 | "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @.*scm-breakpoint.c:$mult_line>" \ | |
65 | "check multiply breakpoint" | |
66 | gdb_test "guile (print (breakpoint-location mult-bkpt))" \ | |
67 | "scm-breakpoint\.c:${mult_line}*" \ | |
68 | "check multiply breakpoint location" | |
69 | ||
70 | # Check hit and ignore counts. | |
71 | gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \ | |
72 | "= 1" "check multiply breakpoint hit count" | |
73 | gdb_scm_test_silent_cmd "guile (set-breakpoint-ignore-count! mult-bkpt 4)" \ | |
74 | "set multiply breakpoint ignore count" | |
75 | gdb_continue_to_breakpoint "Break at multiply." | |
76 | gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \ | |
77 | "= 6" "check multiply breakpoint hit count 2" | |
78 | gdb_test "print result" \ | |
79 | " = 545" "check expected variable result after 6 iterations" | |
80 | ||
81 | # Test breakpoint is enabled and disabled correctly. | |
82 | gdb_breakpoint [gdb_get_line_number "Break at add."] | |
83 | gdb_continue_to_breakpoint "Break at add." | |
84 | gdb_test "guile (print (breakpoint-enabled? mult-bkpt))" \ | |
85 | "= #t" "check multiply breakpoint enabled" | |
86 | gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #f)" \ | |
87 | "set multiply breakpoint disabled" | |
88 | gdb_continue_to_breakpoint "Break at add." | |
89 | gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #t)" \ | |
90 | "set multiply breakpoint enabled" | |
91 | gdb_continue_to_breakpoint "Break at multiply." | |
92 | ||
93 | # Test other getters and setters. | |
94 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
95 | "get breakpoint list 3" | |
96 | gdb_test "guile (print (breakpoint-thread mult-bkpt))" \ | |
97 | "= #f" "check breakpoint thread" | |
98 | gdb_test "guile (print (= (breakpoint-type mult-bkpt) BP_BREAKPOINT))" \ | |
99 | "= #t" "check breakpoint type" | |
100 | gdb_test "guile (print (map breakpoint-number blist))" \ | |
101 | "= \\(1 2 3\\)" "check breakpoint numbers" | |
102 | } | |
103 | } | |
104 | ||
105 | proc test_bkpt_deletion { } { | |
106 | global srcfile testfile hex decimal | |
107 | ||
108 | with_test_prefix test_bkpt_deletion { | |
109 | # Start with a fresh gdb. | |
110 | clean_restart ${testfile} | |
111 | ||
112 | if ![gdb_guile_runto_main] { | |
113 | return | |
114 | } | |
115 | ||
116 | # Test breakpoints are deleted correctly. | |
117 | set deltst_location [gdb_get_line_number "Break at multiply."] | |
118 | set end_location [gdb_get_line_number "Break at end."] | |
119 | gdb_scm_test_silent_cmd "guile (define dp1 (create-breakpoint! \"$deltst_location\"))" \ | |
120 | "create deltst breakpoint" | |
121 | gdb_breakpoint [gdb_get_line_number "Break at end."] | |
122 | gdb_scm_test_silent_cmd "guile (define del-list (breakpoints))" \ | |
123 | "get breakpoint list 4" | |
124 | gdb_test "guile (print (length del-list))" \ | |
125 | "= 3" "number of breakpoints before delete" | |
126 | gdb_continue_to_breakpoint "Break at multiply." \ | |
127 | ".*/$srcfile:$deltst_location.*" | |
128 | gdb_scm_test_silent_cmd "guile (breakpoint-delete! dp1)" \ | |
129 | "delete breakpoint" | |
130 | gdb_test "guile (print (breakpoint-number dp1))" \ | |
131 | "ERROR: .*: Invalid object: <gdb:breakpoint> in position 1: #<gdb:breakpoint #2>.*" \ | |
132 | "check breakpoint invalidated" | |
133 | gdb_scm_test_silent_cmd "guile (set! del-list (breakpoints))" \ | |
134 | "get breakpoint list 5" | |
135 | gdb_test "guile (print (length del-list))" \ | |
136 | "= 2" "number of breakpoints after delete" | |
137 | gdb_continue_to_breakpoint "Break at end." ".*/$srcfile:$end_location.*" | |
138 | } | |
139 | } | |
140 | ||
141 | proc test_bkpt_cond_and_cmds { } { | |
142 | global srcfile testfile hex decimal | |
143 | ||
144 | with_test_prefix test_bkpt_cond_and_cmds { | |
145 | # Start with a fresh gdb. | |
146 | clean_restart ${testfile} | |
147 | ||
148 | if ![gdb_guile_runto_main] { | |
149 | return | |
150 | } | |
151 | ||
152 | # Test conditional setting. | |
153 | set bp_location1 [gdb_get_line_number "Break at multiply."] | |
154 | gdb_scm_test_silent_cmd "guile (define bp1 (create-breakpoint! \"$bp_location1\"))" \ | |
155 | "create multiply breakpoint" | |
156 | gdb_continue_to_breakpoint "Break at multiply." | |
157 | gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 \"i == 5\")" \ | |
158 | "set condition" | |
159 | gdb_test "guile (print (breakpoint-condition bp1))" \ | |
160 | "= i == 5" "test condition has been set" | |
161 | gdb_continue_to_breakpoint "Break at multiply." | |
162 | gdb_test "print i" \ | |
163 | "5" "test conditional breakpoint stopped after five iterations" | |
164 | gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 #f)" \ | |
165 | "clear condition" | |
166 | gdb_test "guile (print (breakpoint-condition bp1))" \ | |
167 | "= #f" "test condition has been removed" | |
168 | gdb_continue_to_breakpoint "Break at multiply." | |
169 | gdb_test "print i" "6" "test breakpoint stopped after six iterations" | |
170 | ||
171 | # Test commands. | |
172 | gdb_breakpoint [gdb_get_line_number "Break at add."] | |
173 | set test {commands $bpnum} | |
174 | gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } } | |
175 | set test {print "Command for breakpoint has been executed."} | |
176 | gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } } | |
177 | set test {print result} | |
178 | gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } } | |
179 | gdb_test "end" | |
180 | ||
181 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
182 | "get breakpoint list 6" | |
183 | gdb_test "guile (print (breakpoint-commands (list-ref blist (- (length blist) 1))))" \ | |
184 | "print \"Command for breakpoint has been executed.\".*print result" | |
185 | } | |
186 | } | |
187 | ||
188 | proc test_bkpt_invisible { } { | |
189 | global srcfile testfile hex decimal | |
190 | ||
191 | with_test_prefix test_bkpt_invisible { | |
192 | # Start with a fresh gdb. | |
193 | clean_restart ${testfile} | |
194 | ||
195 | if ![gdb_guile_runto_main] { | |
196 | return | |
197 | } | |
198 | ||
199 | # Test invisible breakpoints. | |
200 | delete_breakpoints | |
201 | set ibp_location [gdb_get_line_number "Break at multiply."] | |
202 | gdb_scm_test_silent_cmd "guile (define vbp (create-breakpoint! \"$ibp_location\" #:internal #f))" \ | |
203 | "create visible breakpoint" | |
204 | gdb_scm_test_silent_cmd "guile (define vbp (car (breakpoints)))" \ | |
205 | "get visible breakpoint" | |
206 | gdb_test "guile (print vbp)" \ | |
207 | "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \ | |
208 | "check visible bp obj exists" | |
209 | gdb_test "guile (print (breakpoint-location vbp))" \ | |
210 | "scm-breakpoint\.c:$ibp_location*" "check visible breakpoint location" | |
211 | gdb_test "guile (print (breakpoint-visible? vbp))" \ | |
212 | "= #t" "check breakpoint visibility" | |
213 | gdb_test "info breakpoints" \ | |
214 | "scm-breakpoint\.c:$ibp_location.*" \ | |
215 | "check info breakpoints shows visible breakpoints" | |
216 | delete_breakpoints | |
217 | gdb_scm_test_silent_cmd "guile (define ibp (create-breakpoint! \"$ibp_location\" #:internal #t))" \ | |
218 | "create invisible breakpoint" | |
219 | gdb_test "guile (print ibp)" \ | |
220 | "= #<gdb:breakpoint #-$decimal BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \ | |
221 | "check invisible bp obj exists" | |
222 | gdb_test "guile (print (breakpoint-location ibp))" \ | |
223 | "scm-breakpoint\.c:$ibp_location*" "check invisible breakpoint location" | |
224 | gdb_test "guile (print (breakpoint-visible? ibp))" \ | |
225 | "= #f" "check breakpoint invisibility" | |
226 | gdb_test "info breakpoints" \ | |
227 | "No breakpoints or watchpoints.*" \ | |
228 | "check info breakpoints does not show invisible breakpoints" | |
229 | gdb_test "maint info breakpoints" \ | |
230 | "scm-breakpoint\.c:$ibp_location.*" \ | |
231 | "check maint info breakpoints shows invisible breakpoints" | |
232 | } | |
233 | } | |
234 | ||
235 | proc test_watchpoints { } { | |
236 | global srcfile testfile hex decimal | |
237 | ||
238 | with_test_prefix test_watchpoints { | |
239 | # Start with a fresh gdb. | |
240 | clean_restart ${testfile} | |
241 | ||
242 | # Disable hardware watchpoints if necessary. | |
243 | if [target_info exists gdb,no_hardware_watchpoints] { | |
244 | gdb_test_no_output "set can-use-hw-watchpoints 0" "" | |
245 | } | |
246 | if ![gdb_guile_runto_main] { | |
247 | return | |
248 | } | |
249 | ||
250 | gdb_scm_test_silent_cmd "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \ | |
251 | "create watchpoint" | |
252 | gdb_test "continue" \ | |
253 | ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \ | |
254 | "test watchpoint write" | |
255 | } | |
256 | } | |
257 | ||
258 | proc test_bkpt_internal { } { | |
259 | global srcfile testfile hex decimal | |
260 | ||
261 | with_test_prefix test_bkpt_internal { | |
262 | # Start with a fresh gdb. | |
263 | clean_restart ${testfile} | |
264 | ||
265 | # Disable hardware watchpoints if necessary. | |
266 | if [target_info exists gdb,no_hardware_watchpoints] { | |
267 | gdb_test_no_output "set can-use-hw-watchpoints 0" "" | |
268 | } | |
269 | if ![gdb_guile_runto_main] { | |
270 | return | |
271 | } | |
272 | ||
273 | delete_breakpoints | |
274 | ||
275 | gdb_scm_test_silent_cmd "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE #:internal #t))" \ | |
276 | "create invisible watchpoint" | |
277 | gdb_test "info breakpoints" \ | |
278 | "No breakpoints or watchpoints.*" \ | |
279 | "check info breakpoints does not show invisible watchpoint" | |
280 | gdb_test "maint info breakpoints" \ | |
281 | ".*watchpoint.*result.*" \ | |
282 | "check maint info breakpoints shows invisible watchpoint" | |
283 | gdb_test "continue" \ | |
284 | ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*" \ | |
285 | "test invisible watchpoint write" | |
286 | } | |
287 | } | |
288 | ||
289 | proc test_bkpt_eval_funcs { } { | |
290 | global srcfile testfile hex decimal | |
291 | ||
292 | with_test_prefix test_bkpt_eval_funcs { | |
293 | # Start with a fresh gdb. | |
294 | clean_restart ${testfile} | |
295 | ||
296 | # Disable hardware watchpoints if necessary. | |
297 | if [target_info exists gdb,no_hardware_watchpoints] { | |
298 | gdb_test_no_output "set can-use-hw-watchpoints 0" "" | |
299 | } | |
300 | if ![gdb_guile_runto_main] { | |
301 | return | |
302 | } | |
303 | ||
304 | delete_breakpoints | |
305 | ||
306 | gdb_test_multiline "data collection breakpoint 1" \ | |
307 | "guile" "" \ | |
308 | "(define (make-bp-data) (cons 0 0))" "" \ | |
309 | "(define bp-data-count car)" "" \ | |
310 | "(define set-bp-data-count! set-car!)" "" \ | |
311 | "(define bp-data-inf-i cdr)" "" \ | |
312 | "(define set-bp-data-inf-i! set-cdr!)" "" \ | |
b2715b27 AW |
313 | "(define (bp-eval-count bkpt) (bp-data-count (object-property bkpt 'bp-data)))" "" \ |
314 | "(define (bp-eval-inf-i bkpt) (bp-data-inf-i (object-property bkpt 'bp-data)))" "" \ | |
ed3ef339 DE |
315 | "(define (make-bp-eval location)" "" \ |
316 | " (let ((bp (create-breakpoint! location)))" "" \ | |
b2715b27 | 317 | " (set-object-property! bp 'bp-data (make-bp-data))" "" \ |
ed3ef339 DE |
318 | " (set-breakpoint-stop! bp" "" \ |
319 | " (lambda (bkpt)" "" \ | |
b2715b27 | 320 | " (let ((data (object-property bkpt 'bp-data))" "" \ |
ed3ef339 DE |
321 | " (inf-i (parse-and-eval \"i\")))" "" \ |
322 | " (set-bp-data-count! data (+ (bp-data-count data) 1))" "" \ | |
323 | " (set-bp-data-inf-i! data inf-i)" "" \ | |
324 | " (value=? inf-i 3))))" "" \ | |
325 | " bp))" "" \ | |
326 | "end" "" | |
327 | ||
328 | gdb_test_multiline "data collection breakpoint 2" \ | |
329 | "guile" "" \ | |
330 | "(define (make-bp-also-eval location)" "" \ | |
331 | " (let ((bp (create-breakpoint! location)))" "" \ | |
b2715b27 | 332 | " (set-object-property! bp 'bp-data (make-bp-data))" "" \ |
ed3ef339 DE |
333 | " (set-breakpoint-stop! bp" "" \ |
334 | " (lambda (bkpt)" "" \ | |
b2715b27 | 335 | " (let* ((data (object-property bkpt 'bp-data))" "" \ |
ed3ef339 DE |
336 | " (count (+ (bp-data-count data) 1)))" "" \ |
337 | " (set-bp-data-count! data count)" "" \ | |
338 | " (= count 9))))" "" \ | |
339 | " bp))" "" \ | |
340 | "end" "" | |
341 | ||
342 | gdb_test_multiline "data collection breakpoint 3" \ | |
343 | "guile" "" \ | |
344 | "(define (make-bp-basic location)" "" \ | |
345 | " (let ((bp (create-breakpoint! location)))" "" \ | |
b2715b27 | 346 | " (set-object-property! bp 'bp-data (make-bp-data))" "" \ |
ed3ef339 DE |
347 | " bp))" "" \ |
348 | "end" "" | |
349 | ||
350 | set bp_location2 [gdb_get_line_number "Break at multiply."] | |
351 | set end_location [gdb_get_line_number "Break at end."] | |
352 | gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$bp_location2\"))" \ | |
353 | "create eval-bp1 breakpoint" | |
354 | gdb_scm_test_silent_cmd "guile (define also-eval-bp1 (make-bp-also-eval \"$bp_location2\"))" \ | |
355 | "create also-eval-bp1 breakpoint" | |
356 | gdb_scm_test_silent_cmd "guile (define never-eval-bp1 (make-bp-also-eval \"$end_location\"))" \ | |
357 | "create never-eval-bp1 breakpoint" | |
358 | gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*" | |
359 | gdb_test "print i" "3" "check inferior value matches guile accounting" | |
360 | gdb_test "guile (print (bp-eval-inf-i eval-bp1))" \ | |
361 | "= 3" "check guile accounting matches inferior" | |
362 | gdb_test "guile (print (bp-eval-count also-eval-bp1))" \ | |
363 | "= 4" \ | |
364 | "check non firing same-location breakpoint eval function was also called at each stop 1" | |
365 | gdb_test "guile (print (bp-eval-count eval-bp1))" \ | |
366 | "= 4" \ | |
367 | "check non firing same-location breakpoint eval function was also called at each stop 2" | |
368 | ||
369 | # Check we cannot assign a condition to a breakpoint with a stop-func, | |
370 | # and cannot assign a stop-func to a breakpoint with a condition. | |
371 | ||
372 | delete_breakpoints | |
373 | set cond_bp [gdb_get_line_number "Break at multiply."] | |
374 | gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$cond_bp\"))" \ | |
375 | "create eval-bp1 breakpoint 2" | |
376 | set test_cond {cond $bpnum} | |
377 | gdb_test "$test_cond \"foo==3\"" \ | |
378 | "Only one stop condition allowed.*" | |
379 | gdb_scm_test_silent_cmd "guile (define eval-bp2 (make-bp-basic \"$cond_bp\"))" \ | |
380 | "create basic breakpoint" | |
381 | gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! eval-bp2 \"1==1\")" \ | |
382 | "set a condition" | |
383 | gdb_test_multiline "construct an eval function" \ | |
384 | "guile" "" \ | |
385 | "(define (stop-func bkpt)" "" \ | |
386 | " return #t)" "" \ | |
387 | "end" "" | |
388 | gdb_test "guile (set-breakpoint-stop! eval-bp2 stop-func)" \ | |
389 | "Only one stop condition allowed.*" | |
390 | ||
391 | # Check that stop-func is run when location has normal bp. | |
392 | ||
393 | delete_breakpoints | |
394 | gdb_breakpoint [gdb_get_line_number "Break at multiply."] | |
395 | gdb_scm_test_silent_cmd "guile (define check-eval (make-bp-eval \"$bp_location2\"))" \ | |
396 | "create check-eval breakpoint" | |
397 | gdb_test "guile (print (bp-eval-count check-eval))" \ | |
398 | "= 0" \ | |
399 | "test that evaluate function has not been yet executed (ie count = 0)" | |
400 | gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*" | |
401 | gdb_test "guile (print (bp-eval-count check-eval))" \ | |
402 | "= 1" \ | |
403 | "test that evaluate function is run when location also has normal bp" | |
404 | ||
405 | # Test watchpoints with stop-func. | |
406 | ||
407 | gdb_test_multiline "watchpoint stop func" \ | |
408 | "guile" "" \ | |
409 | "(define (make-wp-eval location)" "" \ | |
410 | " (let ((wp (create-breakpoint! location #:type BP_WATCHPOINT #:wp-class WP_WRITE)))" "" \ | |
411 | " (set-breakpoint-stop! wp" "" \ | |
412 | " (lambda (bkpt)" "" \ | |
413 | " (let ((result (parse-and-eval \"result\")))" "" \ | |
414 | " (value=? result 788))))" "" \ | |
415 | " wp))" "" \ | |
416 | "end" "" | |
417 | ||
418 | delete_breakpoints | |
419 | gdb_scm_test_silent_cmd "guile (define wp1 (make-wp-eval \"result\"))" \ | |
420 | "create watchpoint" | |
421 | gdb_test "continue" ".*\[Ww\]atchpoint.*result.*Old value =.*New value = 788.*" \ | |
422 | "test watchpoint write" | |
423 | ||
424 | # Misc final tests. | |
425 | ||
426 | gdb_test "guile (print (bp-eval-count never-eval-bp1))" \ | |
427 | "= 0" \ | |
428 | "check that this unrelated breakpoints eval function was never called" | |
429 | } | |
430 | } | |
431 | ||
432 | test_bkpt_basic | |
433 | test_bkpt_deletion | |
434 | test_bkpt_cond_and_cmds | |
435 | test_bkpt_invisible | |
436 | test_watchpoints | |
437 | test_bkpt_internal | |
438 | test_bkpt_eval_funcs |