gdb/testsuite/gdb.guile/scm-breakpoint.exp

   1 # Copyright (C) 2010-2024 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 require allow_guile_tests
  22
  23 standard_testfile
  24
  25 if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } {
  26     return -1
  27 }
  28
  29 proc_with_prefix test_bkpt_basic { } {
  30     global srcfile testfile hex decimal
  31
  32     # Start with a fresh gdb.
  33     clean_restart ${testfile}
  34
  35     if ![gdb_guile_runto_main] {
  36         return
  37     }
  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"
 100 }
 101
 102 proc_with_prefix test_bkpt_deletion { } {
 103     global srcfile testfile hex decimal
 104
 105     # Start with a fresh gdb.
 106     clean_restart ${testfile}
 107
 108     if ![gdb_guile_runto_main] {
 109         return
 110     }
 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.*"
 136 }
 137
 138 proc_with_prefix test_bkpt_cond_and_cmds { } {
 139     global srcfile testfile hex decimal
 140
 141     # Start with a fresh gdb.
 142     clean_restart ${testfile}
 143
 144     if ![gdb_guile_runto_main] {
 145         return
 146     }
 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))))" \
 182         "print \"Command for breakpoint has been executed.\".*print result\r\n"
 183 }
 184
 185 proc_with_prefix test_bkpt_invisible { } {
 186     global srcfile testfile hex decimal
 187
 188     # Start with a fresh gdb.
 189     clean_restart ${testfile}
 190
 191     if ![gdb_guile_runto_main] {
 192         return
 193     }
 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"
 232 }
 233
 234 proc_with_prefix test_watchpoints { } {
 235     global srcfile testfile hex decimal
 236
 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
 246     }
 247
 248     gdb_scm_test_silent_cmd  "guile (define wp1 (make-breakpoint \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \
 249         "create watchpoint"
 250     gdb_test "guile (display wp1) (newline)" "#<gdb:breakpoint #-1>" \
 251         "print watchpoint before registering"
 252     gdb_scm_test_silent_cmd "guile (register-breakpoint! wp1)" \
 253         "register wp1"
 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"
 257     gdb_test "continue" \
 258         ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \
 259         "test watchpoint write"
 260
 261     gdb_test "guile (define wp2 (make-breakpoint \"result\" #:wp-class WP_WRITE #:type 999))" \
 262         "(ERROR: )?In procedure gdbscm_make_breakpoint: Out of range: invalid breakpoint type in position 5: 999\r\n.*" \
 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))" \
 265         "(ERROR: )?In procedure gdbscm_make_breakpoint: unsupported breakpoint type in position 5: \"BP_NONE\"\r\n.*" \
 266         "create a breakpoint with an unsupported type"
 267 }
 268
 269 proc_with_prefix test_bkpt_internal { } {
 270     global srcfile testfile hex decimal
 271
 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" ""
 278     }
 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"
 298 }
 299
 300 proc_with_prefix test_bkpt_eval_funcs { } {
 301     global srcfile testfile hex decimal
 302
 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" ""
 309     }
 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"
 446 }
 447
 448 proc_with_prefix test_bkpt_registration {} {
 449     global srcfile testfile
 450
 451     # Start with a fresh gdb.
 452     clean_restart ${testfile}
 453
 454     if ![gdb_guile_runto_main] {
 455         return
 456     }
 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"
 485 }
 486
 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] {
 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
 518 proc_with_prefix test_bkpt_address {} {
 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
 530 proc_with_prefix test_bkpt_probe {} {
 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
 538     if {![gdb_guile_runto_main]} {
 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
 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))" \
 566         "(ERROR: )?In procedure gdbscm_make_breakpoint: unsupported breakpoint type in position 3: \"BP_CATCHPOINT\"\r\n.*" \
 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
 588 test_bkpt_basic
 589 test_bkpt_deletion
 590 test_bkpt_cond_and_cmds
 591 test_bkpt_invisible
 592 test_catchpoints
 593 test_watchpoints
 594 test_bkpt_internal
 595 test_bkpt_eval_funcs
 596 test_bkpt_registration
 597 test_bkpt_temporary
 598 test_bkpt_address
 599 test_bkpt_probe