1 # Copyright (C) 2010-2015 Free Software Foundation, Inc.
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.
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.
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/>.
16 # This file is part of the GDB testsuite.
17 # It tests the mechanism exposing breakpoints to Guile.
19 load_lib gdb-guile.exp
23 if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
27 # Skip all tests if Guile scripting is not enabled.
28 if { [skip_guile_tests] } { continue }
30 proc test_bkpt_basic { } {
31 global srcfile testfile hex decimal
33 with_test_prefix "test_bkpt_basic" {
34 # Start with a fresh gdb.
35 clean_restart ${testfile}
37 if ![gdb_guile_runto_main] {
41 # Initially there should be one breakpoint: main.
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"
51 set mult_line [gdb_get_line_number "Break at multiply."]
52 gdb_breakpoint ${mult_line}
53 gdb_continue_to_breakpoint "Break at multiply."
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"
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"
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."
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"
105 proc test_bkpt_deletion { } {
106 global srcfile testfile hex decimal
108 with_test_prefix test_bkpt_deletion {
109 # Start with a fresh gdb.
110 clean_restart ${testfile}
112 if ![gdb_guile_runto_main] {
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 (make-breakpoint \"$deltst_location\"))" \
120 "create deltst breakpoint"
121 gdb_scm_test_silent_cmd "guile (register-breakpoint! dp1)" \
123 gdb_breakpoint [gdb_get_line_number "Break at end."]
124 gdb_scm_test_silent_cmd "guile (define del-list (breakpoints))" \
125 "get breakpoint list 4"
126 gdb_test "guile (print (length del-list))" \
127 "= 3" "number of breakpoints before delete"
128 gdb_continue_to_breakpoint "Break at multiply." \
129 ".*$srcfile:$deltst_location.*"
130 gdb_scm_test_silent_cmd "guile (delete-breakpoint! dp1)" \
132 gdb_test "guile (print (breakpoint-number dp1))" \
133 "ERROR: .*: Invalid object: <gdb:breakpoint> in position 1: #<gdb:breakpoint #-1>.*" \
134 "check breakpoint invalidated"
135 gdb_scm_test_silent_cmd "guile (set! del-list (breakpoints))" \
136 "get breakpoint list 5"
137 gdb_test "guile (print (length del-list))" \
138 "= 2" "number of breakpoints after delete"
139 gdb_continue_to_breakpoint "Break at end." ".*$srcfile:$end_location.*"
143 proc test_bkpt_cond_and_cmds { } {
144 global srcfile testfile hex decimal
146 with_test_prefix test_bkpt_cond_and_cmds {
147 # Start with a fresh gdb.
148 clean_restart ${testfile}
150 if ![gdb_guile_runto_main] {
154 # Test conditional setting.
155 set bp_location1 [gdb_get_line_number "Break at multiply."]
156 gdb_scm_test_silent_cmd "guile (define bp1 (make-breakpoint \"$bp_location1\"))" \
157 "create multiply breakpoint"
158 gdb_scm_test_silent_cmd "guile (register-breakpoint! bp1)" \
160 gdb_continue_to_breakpoint "Break at multiply."
161 gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 \"i == 5\")" \
163 gdb_test "guile (print (breakpoint-condition bp1))" \
164 "= i == 5" "test condition has been set"
165 gdb_continue_to_breakpoint "Break at multiply."
167 "5" "test conditional breakpoint stopped after five iterations"
168 gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 #f)" \
170 gdb_test "guile (print (breakpoint-condition bp1))" \
171 "= #f" "test condition has been removed"
172 gdb_continue_to_breakpoint "Break at multiply."
173 gdb_test "print i" "6" "test breakpoint stopped after six iterations"
176 gdb_breakpoint [gdb_get_line_number "Break at add."]
177 set test {commands $bpnum}
178 gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
179 set test {print "Command for breakpoint has been executed."}
180 gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
181 set test {print result}
182 gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
185 gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
186 "get breakpoint list 6"
187 gdb_test "guile (print (breakpoint-commands (list-ref blist (- (length blist) 1))))" \
188 "print \"Command for breakpoint has been executed.\".*print result"
192 proc test_bkpt_invisible { } {
193 global srcfile testfile hex decimal
195 with_test_prefix test_bkpt_invisible {
196 # Start with a fresh gdb.
197 clean_restart ${testfile}
199 if ![gdb_guile_runto_main] {
203 # Test invisible breakpoints.
205 set ibp_location [gdb_get_line_number "Break at multiply."]
206 gdb_scm_test_silent_cmd "guile (define vbp1 (make-breakpoint \"$ibp_location\" #:internal #f))" \
207 "create visible breakpoint"
208 gdb_scm_test_silent_cmd "guile (register-breakpoint! vbp1)" \
210 gdb_scm_test_silent_cmd "guile (define vbp (car (breakpoints)))" \
211 "get visible breakpoint"
212 gdb_test "guile (print vbp)" \
213 "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
214 "check visible bp obj exists"
215 gdb_test "guile (print (breakpoint-location vbp))" \
216 "scm-breakpoint\.c:$ibp_location*" "check visible breakpoint location"
217 gdb_test "guile (print (breakpoint-visible? vbp))" \
218 "= #t" "check breakpoint visibility"
219 gdb_test "info breakpoints" \
220 "scm-breakpoint\.c:$ibp_location.*" \
221 "check info breakpoints shows visible breakpoints"
223 gdb_scm_test_silent_cmd "guile (define ibp (make-breakpoint \"$ibp_location\" #:internal #t))" \
224 "create invisible breakpoint"
225 gdb_scm_test_silent_cmd "guile (register-breakpoint! ibp)" \
227 gdb_test "guile (print ibp)" \
228 "= #<gdb:breakpoint #-$decimal BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
229 "check invisible bp obj exists"
230 gdb_test "guile (print (breakpoint-location ibp))" \
231 "scm-breakpoint\.c:$ibp_location*" "check invisible breakpoint location"
232 gdb_test "guile (print (breakpoint-visible? ibp))" \
233 "= #f" "check breakpoint invisibility"
234 gdb_test "info breakpoints" \
235 "No breakpoints or watchpoints.*" \
236 "check info breakpoints does not show invisible breakpoints"
237 gdb_test "maint info breakpoints" \
238 "scm-breakpoint\.c:$ibp_location.*" \
239 "check maint info breakpoints shows invisible breakpoints"
243 proc test_watchpoints { } {
244 global srcfile testfile hex decimal
246 with_test_prefix test_watchpoints {
247 # Start with a fresh gdb.
248 clean_restart ${testfile}
250 # Disable hardware watchpoints if necessary.
251 if [target_info exists gdb,no_hardware_watchpoints] {
252 gdb_test_no_output "set can-use-hw-watchpoints 0" ""
254 if ![gdb_guile_runto_main] {
258 gdb_scm_test_silent_cmd "guile (define wp1 (make-breakpoint \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \
260 gdb_scm_test_silent_cmd "guile (register-breakpoint! wp1)" \
262 gdb_test "continue" \
263 ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \
264 "test watchpoint write"
268 proc test_bkpt_internal { } {
269 global srcfile testfile hex decimal
271 with_test_prefix test_bkpt_internal {
272 # Start with a fresh gdb.
273 clean_restart ${testfile}
275 # Disable hardware watchpoints if necessary.
276 if [target_info exists gdb,no_hardware_watchpoints] {
277 gdb_test_no_output "set can-use-hw-watchpoints 0" ""
279 if ![gdb_guile_runto_main] {
285 gdb_scm_test_silent_cmd "guile (define wp1 (make-breakpoint \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE #:internal #t))" \
286 "create invisible watchpoint"
287 gdb_scm_test_silent_cmd "guile (register-breakpoint! wp1)" \
289 gdb_test "info breakpoints" \
290 "No breakpoints or watchpoints.*" \
291 "check info breakpoints does not show invisible watchpoint"
292 gdb_test "maint info breakpoints" \
293 ".*watchpoint.*result.*" \
294 "check maint info breakpoints shows invisible watchpoint"
295 gdb_test "continue" \
296 ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*" \
297 "test invisible watchpoint write"
301 proc test_bkpt_eval_funcs { } {
302 global srcfile testfile hex decimal
304 with_test_prefix test_bkpt_eval_funcs {
305 # Start with a fresh gdb.
306 clean_restart ${testfile}
308 # Disable hardware watchpoints if necessary.
309 if [target_info exists gdb,no_hardware_watchpoints] {
310 gdb_test_no_output "set can-use-hw-watchpoints 0" ""
312 if ![gdb_guile_runto_main] {
318 # Define create-breakpoint! as a convenient wrapper around
319 # make-breakpoint, register-breakpoint!
320 gdb_test_no_output "guile (define (create-breakpoint! . args) (let ((bp (apply make-breakpoint args))) (register-breakpoint! bp) bp))" \
321 "define create-breakpoint!"
323 gdb_test_multiline "data collection breakpoint 1" \
325 "(define (make-bp-data) (cons 0 0))" "" \
326 "(define bp-data-count car)" "" \
327 "(define set-bp-data-count! set-car!)" "" \
328 "(define bp-data-inf-i cdr)" "" \
329 "(define set-bp-data-inf-i! set-cdr!)" "" \
330 "(define (bp-eval-count bkpt) (bp-data-count (object-property bkpt 'bp-data)))" "" \
331 "(define (bp-eval-inf-i bkpt) (bp-data-inf-i (object-property bkpt 'bp-data)))" "" \
332 "(define (make-bp-eval location)" "" \
333 " (let ((bp (create-breakpoint! location)))" "" \
334 " (set-object-property! bp 'bp-data (make-bp-data))" "" \
335 " (set-breakpoint-stop! bp" "" \
336 " (lambda (bkpt)" "" \
337 " (let ((data (object-property bkpt 'bp-data))" "" \
338 " (inf-i (parse-and-eval \"i\")))" "" \
339 " (set-bp-data-count! data (+ (bp-data-count data) 1))" "" \
340 " (set-bp-data-inf-i! data inf-i)" "" \
341 " (value=? inf-i 3))))" "" \
345 gdb_test_multiline "data collection breakpoint 2" \
347 "(define (make-bp-also-eval location)" "" \
348 " (let ((bp (create-breakpoint! location)))" "" \
349 " (set-object-property! bp 'bp-data (make-bp-data))" "" \
350 " (set-breakpoint-stop! bp" "" \
351 " (lambda (bkpt)" "" \
352 " (let* ((data (object-property bkpt 'bp-data))" "" \
353 " (count (+ (bp-data-count data) 1)))" "" \
354 " (set-bp-data-count! data count)" "" \
355 " (= count 9))))" "" \
359 gdb_test_multiline "data collection breakpoint 3" \
361 "(define (make-bp-basic location)" "" \
362 " (let ((bp (create-breakpoint! location)))" "" \
363 " (set-object-property! bp 'bp-data (make-bp-data))" "" \
367 set bp_location2 [gdb_get_line_number "Break at multiply."]
368 set end_location [gdb_get_line_number "Break at end."]
369 gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$bp_location2\"))" \
370 "create eval-bp1 breakpoint"
371 gdb_scm_test_silent_cmd "guile (define also-eval-bp1 (make-bp-also-eval \"$bp_location2\"))" \
372 "create also-eval-bp1 breakpoint"
373 gdb_scm_test_silent_cmd "guile (define never-eval-bp1 (make-bp-also-eval \"$end_location\"))" \
374 "create never-eval-bp1 breakpoint"
375 gdb_continue_to_breakpoint "Break at multiply." ".*$srcfile:$bp_location2.*"
376 gdb_test "print i" "3" "check inferior value matches guile accounting"
377 gdb_test "guile (print (bp-eval-inf-i eval-bp1))" \
378 "= 3" "check guile accounting matches inferior"
379 gdb_test "guile (print (bp-eval-count also-eval-bp1))" \
381 "check non firing same-location breakpoint eval function was also called at each stop 1"
382 gdb_test "guile (print (bp-eval-count eval-bp1))" \
384 "check non firing same-location breakpoint eval function was also called at each stop 2"
386 # Check we cannot assign a condition to a breakpoint with a stop-func,
387 # and cannot assign a stop-func to a breakpoint with a condition.
390 set cond_bp [gdb_get_line_number "Break at multiply."]
391 gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$cond_bp\"))" \
392 "create eval-bp1 breakpoint 2"
393 set test_cond {cond $bpnum}
394 gdb_test "$test_cond \"foo==3\"" \
395 "Only one stop condition allowed.*"
396 gdb_scm_test_silent_cmd "guile (define eval-bp2 (make-bp-basic \"$cond_bp\"))" \
397 "create basic breakpoint"
398 gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! eval-bp2 \"1==1\")" \
400 gdb_test_multiline "construct an eval function" \
402 "(define (stop-func bkpt)" "" \
405 gdb_test "guile (set-breakpoint-stop! eval-bp2 stop-func)" \
406 "Only one stop condition allowed.*"
408 # Check that stop-func is run when location has normal bp.
411 gdb_breakpoint [gdb_get_line_number "Break at multiply."]
412 gdb_scm_test_silent_cmd "guile (define check-eval (make-bp-eval \"$bp_location2\"))" \
413 "create check-eval breakpoint"
414 gdb_test "guile (print (bp-eval-count check-eval))" \
416 "test that evaluate function has not been yet executed (ie count = 0)"
417 gdb_continue_to_breakpoint "Break at multiply." ".*$srcfile:$bp_location2.*"
418 gdb_test "guile (print (bp-eval-count check-eval))" \
420 "test that evaluate function is run when location also has normal bp"
422 # Test watchpoints with stop-func.
424 gdb_test_multiline "watchpoint stop func" \
426 "(define (make-wp-eval location)" "" \
427 " (let ((wp (create-breakpoint! location #:type BP_WATCHPOINT #:wp-class WP_WRITE)))" "" \
428 " (set-breakpoint-stop! wp" "" \
429 " (lambda (bkpt)" "" \
430 " (let ((result (parse-and-eval \"result\")))" "" \
431 " (value=? result 788))))" "" \
436 gdb_scm_test_silent_cmd "guile (define wp1 (make-wp-eval \"result\"))" \
438 gdb_test "continue" ".*\[Ww\]atchpoint.*result.*Old value =.*New value = 788.*" \
439 "test watchpoint write"
443 gdb_test "guile (print (bp-eval-count never-eval-bp1))" \
445 "check that this unrelated breakpoints eval function was never called"
449 proc test_bkpt_registration {} {
450 global srcfile testfile
452 with_test_prefix "test_bkpt_registration" {
453 # Start with a fresh gdb.
454 clean_restart ${testfile}
456 if ![gdb_guile_runto_main] {
460 # Initially there should be one breakpoint: main.
461 gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
462 "get breakpoint list 1"
463 gdb_test "guile (register-breakpoint! (car blist))" \
464 "ERROR: .*: not a Scheme breakpoint.*" \
465 "try to register a non-guile breakpoint"
467 set bp_location1 [gdb_get_line_number "Break at multiply."]
468 gdb_scm_test_silent_cmd "guile (define bp1 (make-breakpoint \"$bp_location1\"))" \
469 "create multiply breakpoint"
470 gdb_test "guile (print (breakpoint-valid? bp1))" \
471 "= #f" "breakpoint invalid after creation"
472 gdb_scm_test_silent_cmd "guile (register-breakpoint! bp1)" \
474 gdb_test "guile (print (breakpoint-valid? bp1))" \
475 "= #t" "breakpoint valid after registration"
476 gdb_test "guile (register-breakpoint! bp1)" \
477 "ERROR: .*: breakpoint is already registered.*" \
478 "re-register already registered bp1"
479 gdb_scm_test_silent_cmd "guile (delete-breakpoint! bp1)" \
480 "delete registered breakpoint"
481 gdb_test "guile (print (breakpoint-valid? bp1))" \
482 "= #f" "breakpoint invalid after deletion"
483 gdb_scm_test_silent_cmd "guile (register-breakpoint! bp1)" \
485 gdb_test "guile (print (breakpoint-valid? bp1))" \
486 "= #t" "breakpoint valid after re-registration"
492 test_bkpt_cond_and_cmds
497 test_bkpt_registration