]>
Commit | Line | Data |
---|---|---|
1d506c26 | 1 | # Copyright (C) 2010-2024 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 breakpoints to Guile. | |
18 | ||
19 | load_lib gdb-guile.exp | |
20 | ||
e71b6502 TT |
21 | require allow_guile_tests |
22 | ||
ed3ef339 DE |
23 | standard_testfile |
24 | ||
5b362f04 | 25 | if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } { |
ed3ef339 DE |
26 | return -1 |
27 | } | |
28 | ||
a7ed4ea6 | 29 | proc_with_prefix test_bkpt_basic { } { |
ed3ef339 DE |
30 | global srcfile testfile hex decimal |
31 | ||
a7ed4ea6 AB |
32 | # Start with a fresh gdb. |
33 | clean_restart ${testfile} | |
34 | ||
35 | if ![gdb_guile_runto_main] { | |
36 | return | |
ed3ef339 | 37 | } |
a7ed4ea6 AB |
38 | |
39 | # Initially there should be one breakpoint: main. | |
40 | ||
41 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
42 | "get breakpoint list 1" | |
43 | gdb_test "guile (print (car blist))" \ | |
44 | "<gdb:breakpoint #1 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @-qualified main>" \ | |
45 | "check main breakpoint" | |
46 | gdb_test "guile (print (breakpoint-location (car blist)))" \ | |
47 | "main" "check main breakpoint location" | |
48 | ||
49 | set mult_line [gdb_get_line_number "Break at multiply."] | |
50 | gdb_breakpoint ${mult_line} | |
51 | gdb_continue_to_breakpoint "Break at multiply, first time" | |
52 | ||
53 | # Check that the Guile breakpoint code noted the addition of a | |
54 | # breakpoint "behind the scenes". | |
55 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
56 | "get breakpoint list 2" | |
57 | gdb_scm_test_silent_cmd "guile (define mult-bkpt (cadr blist))" \ | |
58 | "get multiply breakpoint" | |
59 | gdb_test "guile (print (length blist))" \ | |
60 | "= 2" "check for two breakpoints" | |
61 | gdb_test "guile (print mult-bkpt)" \ | |
62 | "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @.*scm-breakpoint.c:$mult_line>" \ | |
63 | "check multiply breakpoint" | |
64 | gdb_test "guile (print (breakpoint-location mult-bkpt))" \ | |
65 | "scm-breakpoint\.c:${mult_line}*" \ | |
66 | "check multiply breakpoint location" | |
67 | ||
68 | # Check hit and ignore counts. | |
69 | gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \ | |
70 | "= 1" "check multiply breakpoint hit count" | |
71 | gdb_scm_test_silent_cmd "guile (set-breakpoint-ignore-count! mult-bkpt 4)" \ | |
72 | "set multiply breakpoint ignore count" | |
73 | gdb_continue_to_breakpoint "Break at multiply, second time" | |
74 | gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \ | |
75 | "= 6" "check multiply breakpoint hit count 2" | |
76 | gdb_test "print result" \ | |
77 | " = 545" "check expected variable result after 6 iterations" | |
78 | ||
79 | # Test breakpoint is enabled and disabled correctly. | |
80 | gdb_breakpoint [gdb_get_line_number "Break at add."] | |
81 | gdb_continue_to_breakpoint "Break at add, first time" | |
82 | gdb_test "guile (print (breakpoint-enabled? mult-bkpt))" \ | |
83 | "= #t" "check multiply breakpoint enabled" | |
84 | gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #f)" \ | |
85 | "set multiply breakpoint disabled" | |
86 | gdb_continue_to_breakpoint "Break at add, second time" | |
87 | gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #t)" \ | |
88 | "set multiply breakpoint enabled" | |
89 | gdb_continue_to_breakpoint "Break at multiply, third time" | |
90 | ||
91 | # Test other getters and setters. | |
92 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
93 | "get breakpoint list 3" | |
94 | gdb_test "guile (print (breakpoint-thread mult-bkpt))" \ | |
95 | "= #f" "check breakpoint thread" | |
96 | gdb_test "guile (print (= (breakpoint-type mult-bkpt) BP_BREAKPOINT))" \ | |
97 | "= #t" "check breakpoint type" | |
98 | gdb_test "guile (print (map breakpoint-number blist))" \ | |
99 | "= \\(1 2 3\\)" "check breakpoint numbers" | |
ed3ef339 DE |
100 | } |
101 | ||
a7ed4ea6 | 102 | proc_with_prefix test_bkpt_deletion { } { |
ed3ef339 DE |
103 | global srcfile testfile hex decimal |
104 | ||
a7ed4ea6 AB |
105 | # Start with a fresh gdb. |
106 | clean_restart ${testfile} | |
107 | ||
108 | if ![gdb_guile_runto_main] { | |
109 | return | |
ed3ef339 | 110 | } |
a7ed4ea6 AB |
111 | |
112 | # Test breakpoints are deleted correctly. | |
113 | set deltst_location [gdb_get_line_number "Break at multiply."] | |
114 | set end_location [gdb_get_line_number "Break at end."] | |
115 | gdb_scm_test_silent_cmd "guile (define dp1 (make-breakpoint \"$deltst_location\"))" \ | |
116 | "create deltst breakpoint" | |
117 | gdb_scm_test_silent_cmd "guile (register-breakpoint! dp1)" \ | |
118 | "register dp1" | |
119 | gdb_breakpoint [gdb_get_line_number "Break at end."] | |
120 | gdb_scm_test_silent_cmd "guile (define del-list (breakpoints))" \ | |
121 | "get breakpoint list 4" | |
122 | gdb_test "guile (print (length del-list))" \ | |
123 | "= 3" "number of breakpoints before delete" | |
124 | gdb_continue_to_breakpoint "Break at multiply." \ | |
125 | ".*$srcfile:$deltst_location.*" | |
126 | gdb_scm_test_silent_cmd "guile (delete-breakpoint! dp1)" \ | |
127 | "delete breakpoint" | |
128 | gdb_test "guile (print (breakpoint-number dp1))" \ | |
129 | "ERROR: .*: Invalid object: <gdb:breakpoint> in position 1: #<gdb:breakpoint #-1>.*" \ | |
130 | "check breakpoint invalidated" | |
131 | gdb_scm_test_silent_cmd "guile (set! del-list (breakpoints))" \ | |
132 | "get breakpoint list 5" | |
133 | gdb_test "guile (print (length del-list))" \ | |
134 | "= 2" "number of breakpoints after delete" | |
135 | gdb_continue_to_breakpoint "Break at end." ".*$srcfile:$end_location.*" | |
ed3ef339 DE |
136 | } |
137 | ||
a7ed4ea6 | 138 | proc_with_prefix test_bkpt_cond_and_cmds { } { |
ed3ef339 DE |
139 | global srcfile testfile hex decimal |
140 | ||
a7ed4ea6 AB |
141 | # Start with a fresh gdb. |
142 | clean_restart ${testfile} | |
143 | ||
144 | if ![gdb_guile_runto_main] { | |
145 | return | |
ed3ef339 | 146 | } |
a7ed4ea6 AB |
147 | |
148 | # Test conditional setting. | |
149 | set bp_location1 [gdb_get_line_number "Break at multiply."] | |
150 | gdb_scm_test_silent_cmd "guile (define bp1 (make-breakpoint \"$bp_location1\"))" \ | |
151 | "create multiply breakpoint" | |
152 | gdb_scm_test_silent_cmd "guile (register-breakpoint! bp1)" \ | |
153 | "register bp1" | |
154 | gdb_continue_to_breakpoint "Break at multiply, first time" | |
155 | gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 \"i == 5\")" \ | |
156 | "set condition" | |
157 | gdb_test "guile (print (breakpoint-condition bp1))" \ | |
158 | "= i == 5" "test condition has been set" | |
159 | gdb_continue_to_breakpoint "Break at multiply, second time" | |
160 | gdb_test "print i" \ | |
161 | "5" "test conditional breakpoint stopped after five iterations" | |
162 | gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 #f)" \ | |
163 | "clear condition" | |
164 | gdb_test "guile (print (breakpoint-condition bp1))" \ | |
165 | "= #f" "test condition has been removed" | |
166 | gdb_continue_to_breakpoint "Break at multiply, third time" | |
167 | gdb_test "print i" "6" "test breakpoint stopped after six iterations" | |
168 | ||
169 | # Test commands. | |
170 | gdb_breakpoint [gdb_get_line_number "Break at add."] | |
171 | set test {commands $bpnum} | |
172 | gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } } | |
173 | set test {print "Command for breakpoint has been executed."} | |
174 | gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } } | |
175 | set test {print result} | |
176 | gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } } | |
177 | gdb_test "end" | |
178 | ||
179 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
180 | "get breakpoint list 6" | |
181 | gdb_test "guile (print (breakpoint-commands (list-ref blist (- (length blist) 1))))" \ | |
e2f62013 | 182 | "print \"Command for breakpoint has been executed.\".*print result\r\n" |
ed3ef339 DE |
183 | } |
184 | ||
a7ed4ea6 | 185 | proc_with_prefix test_bkpt_invisible { } { |
ed3ef339 DE |
186 | global srcfile testfile hex decimal |
187 | ||
a7ed4ea6 AB |
188 | # Start with a fresh gdb. |
189 | clean_restart ${testfile} | |
190 | ||
191 | if ![gdb_guile_runto_main] { | |
192 | return | |
ed3ef339 | 193 | } |
a7ed4ea6 AB |
194 | |
195 | # Test invisible breakpoints. | |
196 | delete_breakpoints | |
197 | set ibp_location [gdb_get_line_number "Break at multiply."] | |
198 | gdb_scm_test_silent_cmd "guile (define vbp1 (make-breakpoint \"$ibp_location\" #:internal #f))" \ | |
199 | "create visible breakpoint" | |
200 | gdb_scm_test_silent_cmd "guile (register-breakpoint! vbp1)" \ | |
201 | "register vbp1" | |
202 | gdb_scm_test_silent_cmd "guile (define vbp (car (breakpoints)))" \ | |
203 | "get visible breakpoint" | |
204 | gdb_test "guile (print vbp)" \ | |
205 | "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \ | |
206 | "check visible bp obj exists" | |
207 | gdb_test "guile (print (breakpoint-location vbp))" \ | |
208 | "scm-breakpoint\.c:$ibp_location*" "check visible breakpoint location" | |
209 | gdb_test "guile (print (breakpoint-visible? vbp))" \ | |
210 | "= #t" "check breakpoint visibility" | |
211 | gdb_test "info breakpoints" \ | |
212 | "scm-breakpoint\.c:$ibp_location.*" \ | |
213 | "check info breakpoints shows visible breakpoints" | |
214 | delete_breakpoints | |
215 | gdb_scm_test_silent_cmd "guile (define ibp (make-breakpoint \"$ibp_location\" #:internal #t))" \ | |
216 | "create invisible breakpoint" | |
217 | gdb_scm_test_silent_cmd "guile (register-breakpoint! ibp)" \ | |
218 | "register ibp" | |
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" | |
ed3ef339 DE |
232 | } |
233 | ||
a7ed4ea6 | 234 | proc_with_prefix test_watchpoints { } { |
ed3ef339 DE |
235 | global srcfile testfile hex decimal |
236 | ||
a7ed4ea6 AB |
237 | # Start with a fresh gdb. |
238 | clean_restart ${testfile} | |
239 | ||
240 | # Disable hardware watchpoints if necessary. | |
241 | if [target_info exists gdb,no_hardware_watchpoints] { | |
242 | gdb_test_no_output "set can-use-hw-watchpoints 0" "" | |
243 | } | |
244 | if ![gdb_guile_runto_main] { | |
245 | return | |
ed3ef339 | 246 | } |
a7ed4ea6 AB |
247 | |
248 | gdb_scm_test_silent_cmd "guile (define wp1 (make-breakpoint \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \ | |
249 | "create watchpoint" | |
0618ecf6 AB |
250 | gdb_test "guile (display wp1) (newline)" "#<gdb:breakpoint #-1>" \ |
251 | "print watchpoint before registering" | |
a7ed4ea6 AB |
252 | gdb_scm_test_silent_cmd "guile (register-breakpoint! wp1)" \ |
253 | "register wp1" | |
0618ecf6 AB |
254 | gdb_test "guile (display wp1) (newline)" \ |
255 | "#<gdb:breakpoint #${decimal} BP_(?:HARDWARE_)?WATCHPOINT enabled noisy hit:0 ignore:0>" \ | |
256 | "print watchpoint after registering" | |
a7ed4ea6 AB |
257 | gdb_test "continue" \ |
258 | ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \ | |
259 | "test watchpoint write" | |
81b327aa AB |
260 | |
261 | gdb_test "guile (define wp2 (make-breakpoint \"result\" #:wp-class WP_WRITE #:type 999))" \ | |
6bbe1a92 | 262 | "(ERROR: )?In procedure gdbscm_make_breakpoint: Out of range: invalid breakpoint type in position 5: 999\r\n.*" \ |
81b327aa AB |
263 | "create a breakpoint with an invalid type number" |
264 | gdb_test "guile (define wp2 (make-breakpoint \"result\" #:wp-class WP_WRITE #:type BP_NONE))" \ | |
6bbe1a92 | 265 | "(ERROR: )?In procedure gdbscm_make_breakpoint: unsupported breakpoint type in position 5: \"BP_NONE\"\r\n.*" \ |
81b327aa | 266 | "create a breakpoint with an unsupported type" |
ed3ef339 DE |
267 | } |
268 | ||
a7ed4ea6 | 269 | proc_with_prefix test_bkpt_internal { } { |
ed3ef339 DE |
270 | global srcfile testfile hex decimal |
271 | ||
a7ed4ea6 AB |
272 | # Start with a fresh gdb. |
273 | clean_restart ${testfile} | |
274 | ||
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" "" | |
ed3ef339 | 278 | } |
a7ed4ea6 AB |
279 | if ![gdb_guile_runto_main] { |
280 | return | |
281 | } | |
282 | ||
283 | delete_breakpoints | |
284 | ||
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)" \ | |
288 | "register 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" | |
ed3ef339 DE |
298 | } |
299 | ||
a7ed4ea6 | 300 | proc_with_prefix test_bkpt_eval_funcs { } { |
ed3ef339 DE |
301 | global srcfile testfile hex decimal |
302 | ||
a7ed4ea6 AB |
303 | # Start with a fresh gdb. |
304 | clean_restart ${testfile} | |
305 | ||
306 | # Disable hardware watchpoints if necessary. | |
307 | if [target_info exists gdb,no_hardware_watchpoints] { | |
308 | gdb_test_no_output "set can-use-hw-watchpoints 0" "" | |
ed3ef339 | 309 | } |
a7ed4ea6 AB |
310 | if ![gdb_guile_runto_main] { |
311 | return | |
312 | } | |
313 | ||
314 | delete_breakpoints | |
315 | ||
316 | # Define create-breakpoint! as a convenient wrapper around | |
317 | # make-breakpoint, register-breakpoint! | |
318 | gdb_test_no_output "guile (define (create-breakpoint! . args) (let ((bp (apply make-breakpoint args))) (register-breakpoint! bp) bp))" \ | |
319 | "define create-breakpoint!" | |
320 | ||
321 | gdb_test_multiline "data collection breakpoint 1" \ | |
322 | "guile" "" \ | |
323 | "(define (make-bp-data) (cons 0 0))" "" \ | |
324 | "(define bp-data-count car)" "" \ | |
325 | "(define set-bp-data-count! set-car!)" "" \ | |
326 | "(define bp-data-inf-i cdr)" "" \ | |
327 | "(define set-bp-data-inf-i! set-cdr!)" "" \ | |
328 | "(define (bp-eval-count bkpt) (bp-data-count (object-property bkpt 'bp-data)))" "" \ | |
329 | "(define (bp-eval-inf-i bkpt) (bp-data-inf-i (object-property bkpt 'bp-data)))" "" \ | |
330 | "(define (make-bp-eval location)" "" \ | |
331 | " (let ((bp (create-breakpoint! location)))" "" \ | |
332 | " (set-object-property! bp 'bp-data (make-bp-data))" "" \ | |
333 | " (set-breakpoint-stop! bp" "" \ | |
334 | " (lambda (bkpt)" "" \ | |
335 | " (let ((data (object-property bkpt 'bp-data))" "" \ | |
336 | " (inf-i (parse-and-eval \"i\")))" "" \ | |
337 | " (set-bp-data-count! data (+ (bp-data-count data) 1))" "" \ | |
338 | " (set-bp-data-inf-i! data inf-i)" "" \ | |
339 | " (value=? inf-i 3))))" "" \ | |
340 | " bp))" "" \ | |
341 | "end" "" | |
342 | ||
343 | gdb_test_multiline "data collection breakpoint 2" \ | |
344 | "guile" "" \ | |
345 | "(define (make-bp-also-eval location)" "" \ | |
346 | " (let ((bp (create-breakpoint! location)))" "" \ | |
347 | " (set-object-property! bp 'bp-data (make-bp-data))" "" \ | |
348 | " (set-breakpoint-stop! bp" "" \ | |
349 | " (lambda (bkpt)" "" \ | |
350 | " (let* ((data (object-property bkpt 'bp-data))" "" \ | |
351 | " (count (+ (bp-data-count data) 1)))" "" \ | |
352 | " (set-bp-data-count! data count)" "" \ | |
353 | " (= count 9))))" "" \ | |
354 | " bp))" "" \ | |
355 | "end" "" | |
356 | ||
357 | gdb_test_multiline "data collection breakpoint 3" \ | |
358 | "guile" "" \ | |
359 | "(define (make-bp-basic location)" "" \ | |
360 | " (let ((bp (create-breakpoint! location)))" "" \ | |
361 | " (set-object-property! bp 'bp-data (make-bp-data))" "" \ | |
362 | " bp))" "" \ | |
363 | "end" "" | |
364 | ||
365 | set bp_location2 [gdb_get_line_number "Break at multiply."] | |
366 | set end_location [gdb_get_line_number "Break at end."] | |
367 | gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$bp_location2\"))" \ | |
368 | "create eval-bp1 breakpoint" | |
369 | gdb_scm_test_silent_cmd "guile (define also-eval-bp1 (make-bp-also-eval \"$bp_location2\"))" \ | |
370 | "create also-eval-bp1 breakpoint" | |
371 | gdb_scm_test_silent_cmd "guile (define never-eval-bp1 (make-bp-also-eval \"$end_location\"))" \ | |
372 | "create never-eval-bp1 breakpoint" | |
373 | gdb_continue_to_breakpoint "Break at multiply, first time" \ | |
374 | ".*$srcfile:$bp_location2.*" | |
375 | gdb_test "print i" "3" "check inferior value matches guile accounting" | |
376 | gdb_test "guile (print (bp-eval-inf-i eval-bp1))" \ | |
377 | "= 3" "check guile accounting matches inferior" | |
378 | gdb_test "guile (print (bp-eval-count also-eval-bp1))" \ | |
379 | "= 4" \ | |
380 | "check non firing same-location breakpoint eval function was also called at each stop 1" | |
381 | gdb_test "guile (print (bp-eval-count eval-bp1))" \ | |
382 | "= 4" \ | |
383 | "check non firing same-location breakpoint eval function was also called at each stop 2" | |
384 | ||
385 | # Check we cannot assign a condition to a breakpoint with a stop-func, | |
386 | # and cannot assign a stop-func to a breakpoint with a condition. | |
387 | ||
388 | delete_breakpoints | |
389 | set cond_bp [gdb_get_line_number "Break at multiply."] | |
390 | gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$cond_bp\"))" \ | |
391 | "create eval-bp1 breakpoint 2" | |
392 | set test_cond {cond $bpnum} | |
393 | gdb_test "$test_cond \"foo==3\"" \ | |
394 | "Only one stop condition allowed.*" | |
395 | gdb_scm_test_silent_cmd "guile (define eval-bp2 (make-bp-basic \"$cond_bp\"))" \ | |
396 | "create basic breakpoint" | |
397 | gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! eval-bp2 \"1==1\")" \ | |
398 | "set a condition" | |
399 | gdb_test_multiline "construct an eval function" \ | |
400 | "guile" "" \ | |
401 | "(define (stop-func bkpt)" "" \ | |
402 | " return #t)" "" \ | |
403 | "end" "" | |
404 | gdb_test "guile (set-breakpoint-stop! eval-bp2 stop-func)" \ | |
405 | "Only one stop condition allowed.*" | |
406 | ||
407 | # Check that stop-func is run when location has normal bp. | |
408 | ||
409 | delete_breakpoints | |
410 | gdb_breakpoint [gdb_get_line_number "Break at multiply."] | |
411 | gdb_scm_test_silent_cmd "guile (define check-eval (make-bp-eval \"$bp_location2\"))" \ | |
412 | "create check-eval breakpoint" | |
413 | gdb_test "guile (print (bp-eval-count check-eval))" \ | |
414 | "= 0" \ | |
415 | "test that evaluate function has not been yet executed (ie count = 0)" | |
416 | gdb_continue_to_breakpoint "Break at multiply, second time" \ | |
417 | ".*$srcfile:$bp_location2.*" | |
418 | gdb_test "guile (print (bp-eval-count check-eval))" \ | |
419 | "= 1" \ | |
420 | "test that evaluate function is run when location also has normal bp" | |
421 | ||
422 | # Test watchpoints with stop-func. | |
423 | ||
424 | gdb_test_multiline "watchpoint stop func" \ | |
425 | "guile" "" \ | |
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))))" "" \ | |
432 | " wp))" "" \ | |
433 | "end" "" | |
434 | ||
435 | delete_breakpoints | |
436 | gdb_scm_test_silent_cmd "guile (define wp1 (make-wp-eval \"result\"))" \ | |
437 | "create watchpoint" | |
438 | gdb_test "continue" ".*\[Ww\]atchpoint.*result.*Old value =.*New value = 788.*" \ | |
439 | "test watchpoint write" | |
440 | ||
441 | # Misc final tests. | |
442 | ||
443 | gdb_test "guile (print (bp-eval-count never-eval-bp1))" \ | |
444 | "= 0" \ | |
445 | "check that this unrelated breakpoints eval function was never called" | |
ed3ef339 DE |
446 | } |
447 | ||
a7ed4ea6 | 448 | proc_with_prefix test_bkpt_registration {} { |
16f691fb DE |
449 | global srcfile testfile |
450 | ||
a7ed4ea6 AB |
451 | # Start with a fresh gdb. |
452 | clean_restart ${testfile} | |
453 | ||
454 | if ![gdb_guile_runto_main] { | |
455 | return | |
16f691fb | 456 | } |
a7ed4ea6 AB |
457 | |
458 | # Initially there should be one breakpoint: main. | |
459 | gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \ | |
460 | "get breakpoint list 1" | |
461 | gdb_test "guile (register-breakpoint! (car blist))" \ | |
462 | "ERROR: .*: not a Scheme breakpoint.*" \ | |
463 | "try to register a non-guile breakpoint" | |
464 | ||
465 | set bp_location1 [gdb_get_line_number "Break at multiply."] | |
466 | gdb_scm_test_silent_cmd "guile (define bp1 (make-breakpoint \"$bp_location1\"))" \ | |
467 | "create multiply breakpoint" | |
468 | gdb_test "guile (print (breakpoint-valid? bp1))" \ | |
469 | "= #f" "breakpoint invalid after creation" | |
470 | gdb_scm_test_silent_cmd "guile (register-breakpoint! bp1)" \ | |
471 | "register bp1" | |
472 | gdb_test "guile (print (breakpoint-valid? bp1))" \ | |
473 | "= #t" "breakpoint valid after registration" | |
474 | gdb_test "guile (register-breakpoint! bp1)" \ | |
475 | "ERROR: .*: breakpoint is already registered.*" \ | |
476 | "re-register already registered bp1" | |
477 | gdb_scm_test_silent_cmd "guile (delete-breakpoint! bp1)" \ | |
478 | "delete registered breakpoint" | |
479 | gdb_test "guile (print (breakpoint-valid? bp1))" \ | |
480 | "= #f" "breakpoint invalid after deletion" | |
481 | gdb_scm_test_silent_cmd "guile (register-breakpoint! bp1)" \ | |
482 | "re-register bp1" | |
483 | gdb_test "guile (print (breakpoint-valid? bp1))" \ | |
484 | "= #t" "breakpoint valid after re-registration" | |
16f691fb DE |
485 | } |
486 | ||
ad42014b GB |
487 | proc_with_prefix test_bkpt_temporary { } { |
488 | global srcfile testfile hex decimal | |
489 | ||
490 | # Start with a fresh gdb. | |
491 | clean_restart ${testfile} | |
492 | ||
493 | if ![gdb_guile_runto_main] { | |
ad42014b GB |
494 | return 0 |
495 | } | |
496 | delete_breakpoints | |
497 | ||
498 | set ibp_location [gdb_get_line_number "Break at multiply."] | |
499 | gdb_scm_test_silent_cmd "guile (define ibp (make-breakpoint \"$ibp_location\" #:temporary #t))" \ | |
500 | "create temporary breakpoint" | |
501 | gdb_scm_test_silent_cmd "guile (register-breakpoint! ibp)" \ | |
502 | "register ibp" | |
503 | gdb_test "info breakpoints" \ | |
504 | "2.*breakpoint.*del.*scm-breakpoint\.c:$ibp_location.*" \ | |
505 | "check info breakpoints shows breakpoint with temporary status" | |
506 | gdb_test "guile (print (breakpoint-location ibp))" "scm-breakpoint\.c:$ibp_location*" \ | |
507 | "check temporary breakpoint location" | |
508 | gdb_test "guile (print (breakpoint-temporary? ibp))" "#t" \ | |
509 | "check breakpoint temporary status" | |
510 | gdb_continue_to_breakpoint "Break at multiply." \ | |
511 | ".*$srcfile:$ibp_location.*" | |
512 | gdb_test "guile (print (breakpoint-temporary? ibp))" "Invalid object: <gdb:breakpoint>.*" \ | |
513 | "check temporary breakpoint is deleted after being hit" | |
514 | gdb_test "info breakpoints" "No breakpoints or watchpoints.*" \ | |
515 | "check info breakpoints shows temporary breakpoint is deleted" | |
516 | } | |
517 | ||
a7ed4ea6 | 518 | proc_with_prefix test_bkpt_address {} { |
a96e36da KS |
519 | global decimal srcfile |
520 | ||
521 | # Leading whitespace is intentional! | |
522 | gdb_scm_test_silent_cmd \ | |
523 | "guile (define bp1 (make-breakpoint \" *multiply\"))" \ | |
524 | "create address breakpoint a ' *multiply'" 1 | |
525 | ||
526 | gdb_test "guile (register-breakpoint! bp1)" \ | |
527 | ".*Breakpoint ($decimal)+ at .*$srcfile, line ($decimal)+\." | |
528 | } | |
529 | ||
a7ed4ea6 | 530 | proc_with_prefix test_bkpt_probe {} { |
bac7c5cf GB |
531 | global decimal hex testfile srcfile |
532 | ||
533 | if { [prepare_for_testing "failed to prepare" ${testfile}-probes \ | |
534 | ${srcfile} {additional_flags=-DUSE_PROBES}] } { | |
535 | return -1 | |
536 | } | |
537 | ||
f50c72da | 538 | if {![gdb_guile_runto_main]} { |
bac7c5cf GB |
539 | return |
540 | } | |
541 | ||
542 | gdb_scm_test_silent_cmd \ | |
543 | "guile (define bp1 (make-breakpoint \"-probe test:result_updated\"))" \ | |
544 | "create probe breakpoint" | |
545 | ||
546 | gdb_test \ | |
547 | "guile (register-breakpoint! bp1)" \ | |
548 | "Breakpoint $decimal at $hex" \ | |
549 | "register probe breakpoint" | |
550 | } | |
551 | ||
08080f97 AB |
552 | proc_with_prefix test_catchpoints {} { |
553 | global srcfile testfile | |
554 | global gdb_prompt decimal | |
555 | ||
556 | # Start with a fresh gdb. | |
557 | clean_restart ${testfile} | |
558 | ||
559 | if ![gdb_guile_runto_main] { | |
560 | return | |
561 | } | |
562 | ||
563 | # Try to create a catchpoint, currently this isn't supported via | |
564 | # the guile api. | |
565 | gdb_test "guile (define cp (make-breakpoint \"syscall\" #:type BP_CATCHPOINT))" \ | |
6bbe1a92 | 566 | "(ERROR: )?In procedure gdbscm_make_breakpoint: unsupported breakpoint type in position 3: \"BP_CATCHPOINT\"\r\n.*" \ |
08080f97 AB |
567 | "create a catchpoint via the api" |
568 | ||
569 | # Setup a catchpoint. | |
570 | set num "XXX" | |
571 | gdb_test_multiple "catch syscall" "" { | |
572 | -re "The feature \'catch syscall\' is not supported.*\r\n$gdb_prompt $" { | |
573 | unsupported "catch syscall isn't supported" | |
574 | return -1 | |
575 | } | |
576 | -re "Catchpoint ($decimal) \\(any syscall\\)\r\n$gdb_prompt $" { | |
577 | set num $expect_out(1,string) | |
578 | pass $gdb_test_name | |
579 | } | |
580 | } | |
581 | ||
582 | # Look for the catchpoint in the breakpoint list. | |
583 | gdb_test "guile (for-each (lambda (b) (if (= (breakpoint-type b) BP_CATCHPOINT) (begin (display b) (newline)))) (breakpoints))" \ | |
584 | "#<gdb:breakpoint #${num} BP_CATCHPOINT enabled noisy hit:0 ignore:0>" \ | |
585 | "look for BP_CATCHPOINT in breakpoint list" | |
586 | } | |
587 | ||
ed3ef339 DE |
588 | test_bkpt_basic |
589 | test_bkpt_deletion | |
590 | test_bkpt_cond_and_cmds | |
591 | test_bkpt_invisible | |
08080f97 | 592 | test_catchpoints |
ed3ef339 DE |
593 | test_watchpoints |
594 | test_bkpt_internal | |
595 | test_bkpt_eval_funcs | |
16f691fb | 596 | test_bkpt_registration |
ad42014b | 597 | test_bkpt_temporary |
a96e36da | 598 | test_bkpt_address |
bac7c5cf | 599 | test_bkpt_probe |