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

   1 # Copyright (C) 2010-2015 Free Software Foundation, Inc.
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 3 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 # This file is part of the GDB testsuite.
  17 # It tests the mechanism exposing breakpoints to Guile.
  18
  19 load_lib gdb-guile.exp
  20
  21 standard_testfile
  22
  23 if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
  24     return -1
  25 }
  26
  27 # Skip all tests if Guile scripting is not enabled.
  28 if { [skip_guile_tests] } { continue }
  29
  30 proc test_bkpt_basic { } {
  31     global srcfile testfile hex decimal
  32
  33     with_test_prefix "test_bkpt_basic" {
  34         # Start with a fresh gdb.
  35         clean_restart ${testfile}
  36
  37         if ![gdb_guile_runto_main] {
  38             return
  39         }
  40
  41         # Initially there should be one breakpoint: main.
  42
  43         gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
  44             "get breakpoint list 1"
  45         gdb_test "guile (print (car blist))" \
  46             "<gdb:breakpoint #1 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @main>" \
  47             "check main breakpoint"
  48         gdb_test "guile (print (breakpoint-location (car blist)))" \
  49             "main" "check main breakpoint location"
  50
  51         set mult_line [gdb_get_line_number "Break at multiply."]
  52         gdb_breakpoint ${mult_line}
  53         gdb_continue_to_breakpoint "Break at multiply."
  54
  55         # Check that the Guile breakpoint code noted the addition of a
  56         # breakpoint "behind the scenes".
  57         gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
  58             "get breakpoint list 2"
  59         gdb_scm_test_silent_cmd "guile (define mult-bkpt (cadr blist))" \
  60             "get multiply breakpoint"
  61         gdb_test "guile (print (length blist))" \
  62             "= 2" "check for two breakpoints"
  63         gdb_test "guile (print mult-bkpt)" \
  64             "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @.*scm-breakpoint.c:$mult_line>" \
  65             "check multiply breakpoint"
  66         gdb_test "guile (print (breakpoint-location mult-bkpt))" \
  67             "scm-breakpoint\.c:${mult_line}*" \
  68             "check multiply breakpoint location"
  69
  70         # Check hit and ignore counts.
  71         gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \
  72             "= 1" "check multiply breakpoint hit count"
  73         gdb_scm_test_silent_cmd "guile (set-breakpoint-ignore-count! mult-bkpt 4)" \
  74             "set multiply breakpoint ignore count"
  75         gdb_continue_to_breakpoint "Break at multiply."
  76         gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \
  77             "= 6" "check multiply breakpoint hit count 2"
  78         gdb_test "print result" \
  79             " = 545" "check expected variable result after 6 iterations"
  80
  81         # Test breakpoint is enabled and disabled correctly.
  82         gdb_breakpoint [gdb_get_line_number "Break at add."]
  83         gdb_continue_to_breakpoint "Break at add."
  84         gdb_test "guile (print (breakpoint-enabled? mult-bkpt))" \
  85             "= #t" "check multiply breakpoint enabled"
  86         gdb_scm_test_silent_cmd  "guile (set-breakpoint-enabled! mult-bkpt #f)" \
  87             "set multiply breakpoint disabled"
  88         gdb_continue_to_breakpoint "Break at add."
  89         gdb_scm_test_silent_cmd  "guile (set-breakpoint-enabled! mult-bkpt #t)" \
  90             "set multiply breakpoint enabled"
  91         gdb_continue_to_breakpoint "Break at multiply."
  92
  93         # Test other getters and setters.
  94         gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
  95             "get breakpoint list 3"
  96         gdb_test "guile (print (breakpoint-thread mult-bkpt))" \
  97             "= #f" "check breakpoint thread"
  98         gdb_test "guile (print (= (breakpoint-type mult-bkpt) BP_BREAKPOINT))" \
  99             "= #t" "check breakpoint type"
 100         gdb_test "guile (print (map breakpoint-number blist))" \
 101             "= \\(1 2 3\\)" "check breakpoint numbers"
 102     }
 103 }
 104
 105 proc test_bkpt_deletion { } {
 106     global srcfile testfile hex decimal
 107
 108     with_test_prefix test_bkpt_deletion {
 109         # Start with a fresh gdb.
 110         clean_restart ${testfile}
 111
 112         if ![gdb_guile_runto_main] {
 113             return
 114         }
 115
 116         # Test breakpoints are deleted correctly.
 117         set deltst_location [gdb_get_line_number "Break at multiply."]
 118         set end_location [gdb_get_line_number "Break at end."]
 119         gdb_scm_test_silent_cmd  "guile (define dp1 (make-breakpoint \"$deltst_location\"))" \
 120             "create deltst breakpoint"
 121         gdb_scm_test_silent_cmd "guile (register-breakpoint! dp1)" \
 122             "register 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)" \
 131             "delete breakpoint"
 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.*"
 140     }
 141 }
 142
 143 proc test_bkpt_cond_and_cmds { } {
 144     global srcfile testfile hex decimal
 145
 146     with_test_prefix test_bkpt_cond_and_cmds {
 147         # Start with a fresh gdb.
 148         clean_restart ${testfile}
 149
 150         if ![gdb_guile_runto_main] {
 151             return
 152         }
 153
 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)" \
 159             "register bp1"
 160         gdb_continue_to_breakpoint "Break at multiply."
 161         gdb_scm_test_silent_cmd  "guile (set-breakpoint-condition! bp1 \"i == 5\")" \
 162             "set condition"
 163         gdb_test "guile (print (breakpoint-condition bp1))" \
 164             "= i == 5" "test condition has been set"
 165         gdb_continue_to_breakpoint "Break at multiply."
 166         gdb_test "print i" \
 167             "5" "test conditional breakpoint stopped after five iterations"
 168         gdb_scm_test_silent_cmd  "guile (set-breakpoint-condition! bp1 #f)" \
 169             "clear condition"
 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"
 174
 175         # Test commands.
 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 } }
 183         gdb_test "end"
 184
 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"
 189     }
 190 }
 191
 192 proc test_bkpt_invisible { } {
 193     global srcfile testfile hex decimal
 194
 195     with_test_prefix test_bkpt_invisible {
 196         # Start with a fresh gdb.
 197         clean_restart ${testfile}
 198
 199         if ![gdb_guile_runto_main] {
 200             return
 201         }
 202
 203         # Test invisible breakpoints.
 204         delete_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)" \
 209             "register 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"
 222         delete_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)" \
 226             "register 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"
 240     }
 241 }
 242
 243 proc test_watchpoints { } {
 244     global srcfile testfile hex decimal
 245
 246     with_test_prefix test_watchpoints {
 247         # Start with a fresh gdb.
 248         clean_restart ${testfile}
 249
 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" ""
 253         }
 254         if ![gdb_guile_runto_main] {
 255             return
 256         }
 257
 258         gdb_scm_test_silent_cmd  "guile (define wp1 (make-breakpoint \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \
 259             "create watchpoint"
 260         gdb_scm_test_silent_cmd "guile (register-breakpoint! wp1)" \
 261             "register wp1"
 262         gdb_test "continue" \
 263             ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \
 264             "test watchpoint write"
 265     }
 266 }
 267
 268 proc test_bkpt_internal { } {
 269     global srcfile testfile hex decimal
 270
 271     with_test_prefix test_bkpt_internal {
 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
 301 proc test_bkpt_eval_funcs { } {
 302     global srcfile testfile hex decimal
 303
 304     with_test_prefix test_bkpt_eval_funcs {
 305         # Start with a fresh gdb.
 306         clean_restart ${testfile}
 307
 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" ""
 311         }
 312         if ![gdb_guile_runto_main] {
 313             return
 314         }
 315
 316         delete_breakpoints
 317
 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!"
 322
 323         gdb_test_multiline "data collection breakpoint 1" \
 324             "guile" "" \
 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))))" "" \
 342             "    bp))" "" \
 343             "end" ""
 344
 345         gdb_test_multiline "data collection breakpoint 2" \
 346             "guile" "" \
 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))))" "" \
 356             "    bp))" "" \
 357             "end" ""
 358
 359         gdb_test_multiline "data collection breakpoint 3" \
 360             "guile" "" \
 361             "(define (make-bp-basic location)" "" \
 362             "  (let ((bp (create-breakpoint! location)))" "" \
 363             "    (set-object-property! bp 'bp-data (make-bp-data))" "" \
 364             "    bp))" "" \
 365             "end" ""
 366
 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))" \
 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." ".*$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
 449 proc test_bkpt_registration {} {
 450     global srcfile testfile
 451
 452     with_test_prefix "test_bkpt_registration" {
 453         # Start with a fresh gdb.
 454         clean_restart ${testfile}
 455
 456         if ![gdb_guile_runto_main] {
 457             return
 458         }
 459
 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"
 466
 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)" \
 473             "register 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)" \
 484             "re-register bp1"
 485         gdb_test "guile (print (breakpoint-valid? bp1))" \
 486             "= #t" "breakpoint valid after re-registration"
 487     }
 488 }
 489
 490 test_bkpt_basic
 491 test_bkpt_deletion
 492 test_bkpt_cond_and_cmds
 493 test_bkpt_invisible
 494 test_watchpoints
 495 test_bkpt_internal
 496 test_bkpt_eval_funcs
 497 test_bkpt_registration