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

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