1# Copyright (C) 2010-2020 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 19load_lib gdb-guile.exp 20 21standard_testfile 22 23if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile}] } { 24 return -1 25} 26 27# Skip all tests if Guile scripting is not enabled. 28if { [skip_guile_tests] } { continue } 29 30proc 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 105proc 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 143proc 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 192proc 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 243proc 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 268proc 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 301proc 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 449proc 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 490proc test_bkpt_address {} { 491 global decimal srcfile 492 493 # Leading whitespace is intentional! 494 gdb_scm_test_silent_cmd \ 495 "guile (define bp1 (make-breakpoint \" *multiply\"))" \ 496 "create address breakpoint a ' *multiply'" 1 497 498 gdb_test "guile (register-breakpoint! bp1)" \ 499 ".*Breakpoint ($decimal)+ at .*$srcfile, line ($decimal)+\." 500} 501 502proc test_bkpt_probe {} { 503 global decimal hex testfile srcfile 504 505 if { [prepare_for_testing "failed to prepare" ${testfile}-probes \ 506 ${srcfile} {additional_flags=-DUSE_PROBES}] } { 507 return -1 508 } 509 510 if ![gdb_guile_runto_main] then { 511 return 512 } 513 514 gdb_scm_test_silent_cmd \ 515 "guile (define bp1 (make-breakpoint \"-probe test:result_updated\"))" \ 516 "create probe breakpoint" 517 518 gdb_test \ 519 "guile (register-breakpoint! bp1)" \ 520 "Breakpoint $decimal at $hex" \ 521 "register probe breakpoint" 522} 523 524test_bkpt_basic 525test_bkpt_deletion 526test_bkpt_cond_and_cmds 527test_bkpt_invisible 528test_watchpoints 529test_bkpt_internal 530test_bkpt_eval_funcs 531test_bkpt_registration 532test_bkpt_address 533test_bkpt_probe 534