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

   1 # Copyright (C) 2010-2014 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 (create-breakpoint! \"$deltst_location\"))" \
 120             "create deltst breakpoint"
 121         gdb_breakpoint [gdb_get_line_number "Break at end."]
 122         gdb_scm_test_silent_cmd "guile (define del-list (breakpoints))" \
 123             "get breakpoint list 4"
 124         gdb_test "guile (print (length del-list))" \
 125             "= 3" "number of breakpoints before delete"
 126         gdb_continue_to_breakpoint "Break at multiply." \
 127             ".*/$srcfile:$deltst_location.*"
 128         gdb_scm_test_silent_cmd  "guile (breakpoint-delete! dp1)" \
 129             "delete breakpoint"
 130         gdb_test "guile (print (breakpoint-number dp1))" \
 131             "ERROR: .*: Invalid object: <gdb:breakpoint> in position 1: #<gdb:breakpoint #2>.*" \
 132             "check breakpoint invalidated"
 133         gdb_scm_test_silent_cmd "guile (set! del-list (breakpoints))" \
 134             "get breakpoint list 5"
 135         gdb_test "guile (print (length del-list))" \
 136             "= 2" "number of breakpoints after delete"
 137         gdb_continue_to_breakpoint "Break at end." ".*/$srcfile:$end_location.*"
 138     }
 139 }
 140
 141 proc test_bkpt_cond_and_cmds { } {
 142     global srcfile testfile hex decimal
 143
 144     with_test_prefix test_bkpt_cond_and_cmds {
 145         # Start with a fresh gdb.
 146         clean_restart ${testfile}
 147
 148         if ![gdb_guile_runto_main] {
 149             return
 150         }
 151
 152         # Test conditional setting.
 153         set bp_location1 [gdb_get_line_number "Break at multiply."]
 154         gdb_scm_test_silent_cmd  "guile (define bp1 (create-breakpoint! \"$bp_location1\"))" \
 155             "create multiply breakpoint"
 156         gdb_continue_to_breakpoint "Break at multiply."
 157         gdb_scm_test_silent_cmd  "guile (set-breakpoint-condition! bp1 \"i == 5\")" \
 158             "set condition"
 159         gdb_test "guile (print (breakpoint-condition bp1))" \
 160             "= i == 5" "test condition has been set"
 161         gdb_continue_to_breakpoint "Break at multiply."
 162         gdb_test "print i" \
 163             "5" "test conditional breakpoint stopped after five iterations"
 164         gdb_scm_test_silent_cmd  "guile (set-breakpoint-condition! bp1 #f)" \
 165             "clear condition"
 166         gdb_test "guile (print (breakpoint-condition bp1))" \
 167             "= #f" "test condition has been removed"
 168         gdb_continue_to_breakpoint "Break at multiply."
 169         gdb_test "print i" "6" "test breakpoint stopped after six iterations"
 170
 171         # Test commands.
 172         gdb_breakpoint [gdb_get_line_number "Break at add."]
 173         set test {commands $bpnum}
 174         gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
 175         set test {print "Command for breakpoint has been executed."}
 176         gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
 177         set test {print result}
 178         gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
 179         gdb_test "end"
 180
 181         gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
 182             "get breakpoint list 6"
 183         gdb_test "guile (print (breakpoint-commands (list-ref blist (- (length blist) 1))))" \
 184             "print \"Command for breakpoint has been executed.\".*print result"
 185     }
 186 }
 187
 188 proc test_bkpt_invisible { } {
 189     global srcfile testfile hex decimal
 190
 191     with_test_prefix test_bkpt_invisible {
 192         # Start with a fresh gdb.
 193         clean_restart ${testfile}
 194
 195         if ![gdb_guile_runto_main] {
 196             return
 197         }
 198
 199         # Test invisible breakpoints.
 200         delete_breakpoints
 201         set ibp_location [gdb_get_line_number "Break at multiply."]
 202         gdb_scm_test_silent_cmd  "guile (define vbp (create-breakpoint! \"$ibp_location\" #:internal #f))" \
 203             "create visible breakpoint"
 204         gdb_scm_test_silent_cmd "guile (define vbp (car (breakpoints)))" \
 205             "get visible breakpoint"
 206         gdb_test "guile (print vbp)" \
 207             "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
 208             "check visible bp obj exists"
 209         gdb_test "guile (print (breakpoint-location vbp))" \
 210             "scm-breakpoint\.c:$ibp_location*" "check visible breakpoint location"
 211         gdb_test "guile (print (breakpoint-visible? vbp))" \
 212             "= #t" "check breakpoint visibility"
 213         gdb_test "info breakpoints" \
 214             "scm-breakpoint\.c:$ibp_location.*" \
 215             "check info breakpoints shows visible breakpoints"
 216         delete_breakpoints
 217         gdb_scm_test_silent_cmd  "guile (define ibp (create-breakpoint! \"$ibp_location\" #:internal #t))" \
 218             "create invisible breakpoint"
 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
 235 proc test_watchpoints { } {
 236     global srcfile testfile hex decimal
 237
 238     with_test_prefix test_watchpoints {
 239         # Start with a fresh gdb.
 240         clean_restart ${testfile}
 241
 242         # Disable hardware watchpoints if necessary.
 243         if [target_info exists gdb,no_hardware_watchpoints] {
 244             gdb_test_no_output "set can-use-hw-watchpoints 0" ""
 245         }
 246         if ![gdb_guile_runto_main] {
 247             return
 248         }
 249
 250         gdb_scm_test_silent_cmd  "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \
 251             "create watchpoint"
 252         gdb_test "continue" \
 253             ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \
 254             "test watchpoint write"
 255     }
 256 }
 257
 258 proc test_bkpt_internal { } {
 259     global srcfile testfile hex decimal
 260
 261     with_test_prefix test_bkpt_internal {
 262         # Start with a fresh gdb.
 263         clean_restart ${testfile}
 264
 265         # Disable hardware watchpoints if necessary.
 266         if [target_info exists gdb,no_hardware_watchpoints] {
 267             gdb_test_no_output "set can-use-hw-watchpoints 0" ""
 268         }
 269         if ![gdb_guile_runto_main] {
 270             return
 271         }
 272
 273         delete_breakpoints
 274
 275         gdb_scm_test_silent_cmd  "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE #:internal #t))" \
 276             "create invisible watchpoint"
 277         gdb_test "info breakpoints" \
 278             "No breakpoints or watchpoints.*" \
 279             "check info breakpoints does not show invisible watchpoint"
 280         gdb_test "maint info breakpoints" \
 281             ".*watchpoint.*result.*" \
 282             "check maint info breakpoints shows invisible watchpoint"
 283         gdb_test "continue" \
 284             ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*" \
 285             "test invisible watchpoint write"
 286     }
 287 }
 288
 289 proc test_bkpt_eval_funcs { } {
 290     global srcfile testfile hex decimal
 291
 292     with_test_prefix test_bkpt_eval_funcs {
 293         # Start with a fresh gdb.
 294         clean_restart ${testfile}
 295
 296         # Disable hardware watchpoints if necessary.
 297         if [target_info exists gdb,no_hardware_watchpoints] {
 298             gdb_test_no_output "set can-use-hw-watchpoints 0" ""
 299         }
 300         if ![gdb_guile_runto_main] {
 301             return
 302         }
 303
 304         delete_breakpoints
 305
 306         gdb_test_multiline "data collection breakpoint 1" \
 307             "guile" "" \
 308             "(define (make-bp-data) (cons 0 0))" "" \
 309             "(define bp-data-count car)" "" \
 310             "(define set-bp-data-count! set-car!)" "" \
 311             "(define bp-data-inf-i cdr)" "" \
 312             "(define set-bp-data-inf-i! set-cdr!)" "" \
 313             "(define (bp-eval-count bkpt) (bp-data-count (object-property bkpt 'bp-data)))" "" \
 314             "(define (bp-eval-inf-i bkpt) (bp-data-inf-i (object-property bkpt 'bp-data)))" "" \
 315             "(define (make-bp-eval location)" "" \
 316             "  (let ((bp (create-breakpoint! location)))" "" \
 317             "    (set-object-property! bp 'bp-data (make-bp-data))" "" \
 318             "    (set-breakpoint-stop! bp" "" \
 319             "       (lambda (bkpt)" "" \
 320             "         (let ((data (object-property bkpt 'bp-data))" "" \
 321             "               (inf-i (parse-and-eval \"i\")))" "" \
 322             "           (set-bp-data-count! data (+ (bp-data-count data) 1))" "" \
 323             "           (set-bp-data-inf-i! data inf-i)" "" \
 324             "           (value=? inf-i 3))))" "" \
 325             "    bp))" "" \
 326             "end" ""
 327
 328         gdb_test_multiline "data collection breakpoint 2" \
 329             "guile" "" \
 330             "(define (make-bp-also-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             "                (count (+ (bp-data-count data) 1)))" "" \
 337             "           (set-bp-data-count! data count)" "" \
 338             "           (= count 9))))" "" \
 339             "    bp))" "" \
 340             "end" ""
 341
 342         gdb_test_multiline "data collection breakpoint 3" \
 343             "guile" "" \
 344             "(define (make-bp-basic location)" "" \
 345             "  (let ((bp (create-breakpoint! location)))" "" \
 346             "    (set-object-property! bp 'bp-data (make-bp-data))" "" \
 347             "    bp))" "" \
 348             "end" ""
 349
 350         set bp_location2 [gdb_get_line_number "Break at multiply."]
 351         set end_location [gdb_get_line_number "Break at end."]
 352         gdb_scm_test_silent_cmd  "guile (define eval-bp1 (make-bp-eval \"$bp_location2\"))" \
 353             "create eval-bp1 breakpoint"
 354         gdb_scm_test_silent_cmd  "guile (define also-eval-bp1 (make-bp-also-eval \"$bp_location2\"))" \
 355             "create also-eval-bp1 breakpoint"
 356         gdb_scm_test_silent_cmd  "guile (define never-eval-bp1 (make-bp-also-eval \"$end_location\"))" \
 357             "create never-eval-bp1 breakpoint"
 358         gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*"
 359         gdb_test "print i" "3" "check inferior value matches guile accounting"
 360         gdb_test "guile (print (bp-eval-inf-i eval-bp1))" \
 361             "= 3" "check guile accounting matches inferior"
 362         gdb_test "guile (print (bp-eval-count also-eval-bp1))" \
 363             "= 4" \
 364             "check non firing same-location breakpoint eval function was also called at each stop 1"
 365         gdb_test "guile (print (bp-eval-count eval-bp1))" \
 366             "= 4" \
 367             "check non firing same-location breakpoint eval function was also called at each stop 2"
 368
 369         # Check we cannot assign a condition to a breakpoint with a stop-func,
 370         # and cannot assign a stop-func to a breakpoint with a condition.
 371
 372         delete_breakpoints
 373         set cond_bp [gdb_get_line_number "Break at multiply."]
 374         gdb_scm_test_silent_cmd  "guile (define eval-bp1 (make-bp-eval \"$cond_bp\"))" \
 375             "create eval-bp1 breakpoint 2"
 376         set test_cond {cond $bpnum}
 377         gdb_test "$test_cond \"foo==3\"" \
 378             "Only one stop condition allowed.*"
 379         gdb_scm_test_silent_cmd  "guile (define eval-bp2 (make-bp-basic \"$cond_bp\"))" \
 380             "create basic breakpoint"
 381         gdb_scm_test_silent_cmd  "guile (set-breakpoint-condition! eval-bp2 \"1==1\")" \
 382             "set a condition"
 383         gdb_test_multiline "construct an eval function" \
 384             "guile" "" \
 385             "(define (stop-func bkpt)" "" \
 386             "   return #t)" "" \
 387             "end" ""
 388         gdb_test "guile (set-breakpoint-stop! eval-bp2 stop-func)"  \
 389             "Only one stop condition allowed.*"
 390
 391         # Check that stop-func is run when location has normal bp.
 392
 393         delete_breakpoints
 394         gdb_breakpoint [gdb_get_line_number "Break at multiply."]
 395         gdb_scm_test_silent_cmd  "guile (define check-eval (make-bp-eval \"$bp_location2\"))" \
 396             "create check-eval breakpoint"
 397         gdb_test "guile (print (bp-eval-count check-eval))" \
 398             "= 0" \
 399             "test that evaluate function has not been yet executed (ie count = 0)"
 400         gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*"
 401         gdb_test "guile (print (bp-eval-count check-eval))" \
 402             "= 1" \
 403             "test that evaluate function is run when location also has normal bp"
 404
 405         # Test watchpoints with stop-func.
 406
 407         gdb_test_multiline "watchpoint stop func" \
 408             "guile" "" \
 409             "(define (make-wp-eval location)" "" \
 410             "  (let ((wp (create-breakpoint! location #:type BP_WATCHPOINT #:wp-class WP_WRITE)))" "" \
 411             "    (set-breakpoint-stop! wp" "" \
 412             "      (lambda (bkpt)" "" \
 413             "        (let ((result (parse-and-eval \"result\")))" "" \
 414             "          (value=? result 788))))" "" \
 415             "    wp))" "" \
 416             "end" ""
 417
 418         delete_breakpoints
 419         gdb_scm_test_silent_cmd  "guile (define wp1 (make-wp-eval \"result\"))" \
 420             "create watchpoint"
 421         gdb_test "continue" ".*\[Ww\]atchpoint.*result.*Old value =.*New value = 788.*" \
 422             "test watchpoint write"
 423
 424         # Misc final tests.
 425
 426         gdb_test "guile (print (bp-eval-count never-eval-bp1))" \
 427             "= 0" \
 428             "check that this unrelated breakpoints eval function was never called"
 429     }
 430 }
 431
 432 test_bkpt_basic
 433 test_bkpt_deletion
 434 test_bkpt_cond_and_cmds
 435 test_bkpt_invisible
 436 test_watchpoints
 437 test_bkpt_internal
 438 test_bkpt_eval_funcs