1 /* Scheme interface to breakpoints.
3 Copyright (C) 2008-2014 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
25 #include "exceptions.h"
26 #include "breakpoint.h"
28 #include "gdbthread.h"
30 #include "cli/cli-script.h"
32 #include "arch-utils.h"
34 #include "guile-internal.h"
36 /* The <gdb:breakpoint> smob.
37 N.B.: The name of this struct is known to breakpoint.h.
39 Note: Breakpoints are added to gdb using a two step process:
40 1) Call make-breakpoint to create a <gdb:breakpoint> object.
41 2) Call register-breakpoint! to add the breakpoint to gdb.
42 It is done this way so that the constructor, make-breakpoint, doesn't have
43 any side-effects. This means that the smob needs to store everything
44 that was passed to make-breakpoint. */
46 typedef struct gdbscm_breakpoint_object
48 /* This always appears first. */
51 /* Non-zero if this breakpoint was created with make-breakpoint. */
54 /* For breakpoints created with make-breakpoint, these are the parameters
55 that were passed to make-breakpoint. These values are not used except
56 to register the breakpoint with GDB. */
59 /* The string representation of the breakpoint.
60 Space for this lives in GC space. */
63 /* The kind of breakpoint.
64 At the moment this can only be one of bp_breakpoint, bp_watchpoint. */
67 /* If a watchpoint, the kind of watchpoint. */
68 enum target_hw_bp_type access_type
;
70 /* Non-zero if the breakpoint is an "internal" breakpoint. */
74 /* The breakpoint number according to gdb.
75 For breakpoints created from Scheme, this has the value -1 until the
76 breakpoint is registered with gdb.
77 This is recorded here because BP will be NULL when deleted. */
80 /* The gdb breakpoint object, or NULL if the breakpoint has not been
81 registered yet, or has been deleted. */
82 struct breakpoint
*bp
;
84 /* Backlink to our containing <gdb:breakpoint> smob.
85 This is needed when we are deleted, we need to unprotect the object
89 /* A stop condition or #f. */
93 static const char breakpoint_smob_name
[] = "gdb:breakpoint";
95 /* The tag Guile knows the breakpoint smob by. */
96 static scm_t_bits breakpoint_smob_tag
;
98 /* Variables used to pass information between the breakpoint_smob
99 constructor and the breakpoint-created hook function. */
100 static SCM pending_breakpoint_scm
= SCM_BOOL_F
;
102 /* Keywords used by create-breakpoint!. */
103 static SCM type_keyword
;
104 static SCM wp_class_keyword
;
105 static SCM internal_keyword
;
107 /* Administrivia for breakpoint smobs. */
109 /* The smob "free" function for <gdb:breakpoint>. */
112 bpscm_free_breakpoint_smob (SCM self
)
114 breakpoint_smob
*bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (self
);
117 bp_smob
->bp
->scm_bp_object
= NULL
;
119 /* Not necessary, done to catch bugs. */
121 bp_smob
->containing_scm
= SCM_UNDEFINED
;
122 bp_smob
->stop
= SCM_UNDEFINED
;
127 /* Return the name of TYPE.
128 This doesn't handle all types, just the ones we export. */
131 bpscm_type_to_string (enum bptype type
)
135 case bp_none
: return "BP_NONE";
136 case bp_breakpoint
: return "BP_BREAKPOINT";
137 case bp_watchpoint
: return "BP_WATCHPOINT";
138 case bp_hardware_watchpoint
: return "BP_HARDWARE_WATCHPOINT";
139 case bp_read_watchpoint
: return "BP_READ_WATCHPOINT";
140 case bp_access_watchpoint
: return "BP_ACCESS_WATCHPOINT";
141 default: return "internal/other";
145 /* Return the name of ENABLE_STATE. */
148 bpscm_enable_state_to_string (enum enable_state enable_state
)
150 switch (enable_state
)
152 case bp_disabled
: return "disabled";
153 case bp_enabled
: return "enabled";
154 case bp_call_disabled
: return "call_disabled";
155 case bp_permanent
: return "permanent";
156 default: return "unknown";
160 /* The smob "print" function for <gdb:breakpoint>. */
163 bpscm_print_breakpoint_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
165 breakpoint_smob
*bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (self
);
166 struct breakpoint
*b
= bp_smob
->bp
;
168 gdbscm_printf (port
, "#<%s", breakpoint_smob_name
);
170 /* Only print what we export to the user.
171 The rest are possibly internal implementation details. */
173 gdbscm_printf (port
, " #%d", bp_smob
->number
);
175 /* Careful, the breakpoint may be invalid. */
178 gdbscm_printf (port
, " %s %s %s",
179 bpscm_type_to_string (b
->type
),
180 bpscm_enable_state_to_string (b
->enable_state
),
181 b
->silent
? "silent" : "noisy");
183 gdbscm_printf (port
, " hit:%d", b
->hit_count
);
184 gdbscm_printf (port
, " ignore:%d", b
->ignore_count
);
186 if (b
->addr_string
!= NULL
)
187 gdbscm_printf (port
, " @%s", b
->addr_string
);
190 scm_puts (">", port
);
192 scm_remember_upto_here_1 (self
);
194 /* Non-zero means success. */
198 /* Low level routine to create a <gdb:breakpoint> object. */
201 bpscm_make_breakpoint_smob (void)
203 breakpoint_smob
*bp_smob
= (breakpoint_smob
*)
204 scm_gc_malloc (sizeof (breakpoint_smob
), breakpoint_smob_name
);
207 memset (bp_smob
, 0, sizeof (*bp_smob
));
208 bp_smob
->number
= -1;
209 bp_smob
->stop
= SCM_BOOL_F
;
210 bp_scm
= scm_new_smob (breakpoint_smob_tag
, (scm_t_bits
) bp_smob
);
211 bp_smob
->containing_scm
= bp_scm
;
212 gdbscm_init_gsmob (&bp_smob
->base
);
217 /* Return non-zero if we want a Scheme wrapper for breakpoint B.
218 If FROM_SCHEME is non-zero,this is called for a breakpoint created
219 by the user from Scheme. Otherwise it is zero. */
222 bpscm_want_scm_wrapper_p (struct breakpoint
*bp
, int from_scheme
)
224 /* Don't create <gdb:breakpoint> objects for internal GDB breakpoints. */
225 if (bp
->number
< 0 && !from_scheme
)
228 /* The others are not supported. */
229 if (bp
->type
!= bp_breakpoint
230 && bp
->type
!= bp_watchpoint
231 && bp
->type
!= bp_hardware_watchpoint
232 && bp
->type
!= bp_read_watchpoint
233 && bp
->type
!= bp_access_watchpoint
)
239 /* Install the Scheme side of a breakpoint, CONTAINING_SCM, in
243 bpscm_attach_scm_to_breakpoint (struct breakpoint
*bp
, SCM containing_scm
)
245 breakpoint_smob
*bp_smob
;
247 bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (containing_scm
);
248 bp_smob
->number
= bp
->number
;
250 bp_smob
->containing_scm
= containing_scm
;
251 bp_smob
->bp
->scm_bp_object
= bp_smob
;
253 /* The owner of this breakpoint is not in GC-controlled memory, so we need
254 to protect it from GC until the breakpoint is deleted. */
255 scm_gc_protect_object (containing_scm
);
258 /* Return non-zero if SCM is a breakpoint smob. */
261 bpscm_is_breakpoint (SCM scm
)
263 return SCM_SMOB_PREDICATE (breakpoint_smob_tag
, scm
);
266 /* (breakpoint? scm) -> boolean */
269 gdbscm_breakpoint_p (SCM scm
)
271 return scm_from_bool (bpscm_is_breakpoint (scm
));
274 /* Returns the <gdb:breakpoint> object in SELF.
275 Throws an exception if SELF is not a <gdb:breakpoint> object. */
278 bpscm_get_breakpoint_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
280 SCM_ASSERT_TYPE (bpscm_is_breakpoint (self
), self
, arg_pos
, func_name
,
281 breakpoint_smob_name
);
286 /* Returns a pointer to the breakpoint smob of SELF.
287 Throws an exception if SELF is not a <gdb:breakpoint> object. */
289 static breakpoint_smob
*
290 bpscm_get_breakpoint_smob_arg_unsafe (SCM self
, int arg_pos
,
291 const char *func_name
)
293 SCM bp_scm
= bpscm_get_breakpoint_arg_unsafe (self
, arg_pos
, func_name
);
294 breakpoint_smob
*bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (bp_scm
);
299 /* Return non-zero if breakpoint BP_SMOB is valid. */
302 bpscm_is_valid (breakpoint_smob
*bp_smob
)
304 return bp_smob
->bp
!= NULL
;
307 /* Returns the breakpoint smob in SELF, verifying it's valid.
308 Throws an exception if SELF is not a <gdb:breakpoint> object,
311 static breakpoint_smob
*
312 bpscm_get_valid_breakpoint_smob_arg_unsafe (SCM self
, int arg_pos
,
313 const char *func_name
)
315 breakpoint_smob
*bp_smob
316 = bpscm_get_breakpoint_smob_arg_unsafe (self
, arg_pos
, func_name
);
318 if (!bpscm_is_valid (bp_smob
))
320 gdbscm_invalid_object_error (func_name
, arg_pos
, self
,
321 _("<gdb:breakpoint>"));
327 /* Breakpoint methods. */
329 /* (make-breakpoint string [#:type integer] [#:wp-class integer]
330 [#:internal boolean) -> <gdb:breakpoint>
332 The result is the <gdb:breakpoint> Scheme object.
333 The breakpoint is not available to be used yet, however.
334 It must still be added to gdb with register-breakpoint!. */
337 gdbscm_make_breakpoint (SCM location_scm
, SCM rest
)
339 const SCM keywords
[] = {
340 type_keyword
, wp_class_keyword
, internal_keyword
, SCM_BOOL_F
344 int type_arg_pos
= -1, access_type_arg_pos
= -1, internal_arg_pos
= -1;
345 int type
= bp_breakpoint
;
346 int access_type
= hw_write
;
349 breakpoint_smob
*bp_smob
;
351 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#iit",
352 location_scm
, &location
, rest
,
353 &type_arg_pos
, &type
,
354 &access_type_arg_pos
, &access_type
,
355 &internal_arg_pos
, &internal
);
357 result
= bpscm_make_breakpoint_smob ();
358 bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (result
);
361 location
= gdbscm_gc_xstrdup (s
);
367 if (access_type_arg_pos
> 0)
369 gdbscm_misc_error (FUNC_NAME
, access_type_arg_pos
,
370 scm_from_int (access_type
),
371 _("access type with breakpoint is not allowed"));
382 gdbscm_out_of_range_error (FUNC_NAME
, access_type_arg_pos
,
383 scm_from_int (access_type
),
384 _("invalid watchpoint class"));
388 gdbscm_out_of_range_error (FUNC_NAME
, access_type_arg_pos
,
390 _("invalid breakpoint type"));
393 bp_smob
->is_scheme_bkpt
= 1;
394 bp_smob
->spec
.location
= location
;
395 bp_smob
->spec
.type
= type
;
396 bp_smob
->spec
.access_type
= access_type
;
397 bp_smob
->spec
.is_internal
= internal
;
402 /* (register-breakpoint! <gdb:breakpoint>) -> unspecified
404 It is an error to register a breakpoint created outside of Guile,
405 or an already-registered breakpoint. */
408 gdbscm_register_breakpoint_x (SCM self
)
410 breakpoint_smob
*bp_smob
411 = bpscm_get_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
412 volatile struct gdb_exception except
;
414 /* We only support registering breakpoints created with make-breakpoint. */
415 if (!bp_smob
->is_scheme_bkpt
)
416 scm_misc_error (FUNC_NAME
, _("not a Scheme breakpoint"), SCM_EOL
);
418 if (bpscm_is_valid (bp_smob
))
419 scm_misc_error (FUNC_NAME
, _("breakpoint is already registered"), SCM_EOL
);
421 pending_breakpoint_scm
= self
;
423 TRY_CATCH (except
, RETURN_MASK_ALL
)
425 char *location
= bp_smob
->spec
.location
;
426 int internal
= bp_smob
->spec
.is_internal
;
428 switch (bp_smob
->spec
.type
)
432 create_breakpoint (get_current_arch (),
433 location
, NULL
, -1, NULL
,
438 &bkpt_breakpoint_ops
,
444 enum target_hw_bp_type access_type
= bp_smob
->spec
.access_type
;
446 if (access_type
== hw_write
)
447 watch_command_wrapper (location
, 0, internal
);
448 else if (access_type
== hw_access
)
449 awatch_command_wrapper (location
, 0, internal
);
450 else if (access_type
== hw_read
)
451 rwatch_command_wrapper (location
, 0, internal
);
453 gdb_assert_not_reached ("invalid access type");
457 gdb_assert_not_reached ("invalid breakpoint type");
460 /* Ensure this gets reset, even if there's an error. */
461 pending_breakpoint_scm
= SCM_BOOL_F
;
462 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
464 return SCM_UNSPECIFIED
;
467 /* (delete-breakpoint! <gdb:breakpoint>) -> unspecified
468 Scheme function which deletes (removes) the underlying GDB breakpoint
469 from GDB's list of breakpoints. This triggers the breakpoint_deleted
470 observer which will call gdbscm_breakpoint_deleted; that function cleans
471 up the Scheme bits. */
474 gdbscm_delete_breakpoint_x (SCM self
)
476 breakpoint_smob
*bp_smob
477 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
478 volatile struct gdb_exception except
;
480 TRY_CATCH (except
, RETURN_MASK_ALL
)
482 delete_breakpoint (bp_smob
->bp
);
484 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
486 return SCM_UNSPECIFIED
;
489 /* iterate_over_breakpoints function for gdbscm_breakpoints. */
492 bpscm_build_bp_list (struct breakpoint
*bp
, void *arg
)
495 breakpoint_smob
*bp_smob
= bp
->scm_bp_object
;
497 /* Lazily create wrappers for breakpoints created outside Scheme. */
501 if (bpscm_want_scm_wrapper_p (bp
, 0))
505 bp_scm
= bpscm_make_breakpoint_smob ();
506 bpscm_attach_scm_to_breakpoint (bp
, bp_scm
);
508 bp_smob
= bp
->scm_bp_object
;
512 /* Not all breakpoints will have a companion Scheme object.
513 Only breakpoints that trigger the created_breakpoint observer call,
514 and satisfy certain conditions (see bpscm_want_scm_wrapper_p),
515 get a companion object (this includes Scheme-created breakpoints). */
518 *list
= scm_cons (bp_smob
->containing_scm
, *list
);
523 /* (breakpoints) -> list
524 Return a list of all breakpoints. */
527 gdbscm_breakpoints (void)
531 /* If iterate_over_breakpoints returns non-NULL it means the iteration
533 In that case abandon building the list and return #f. */
534 if (iterate_over_breakpoints (bpscm_build_bp_list
, &list
) != NULL
)
537 return scm_reverse_x (list
, SCM_EOL
);
540 /* (breakpoint-valid? <gdb:breakpoint>) -> boolean
541 Returns #t if SELF is still valid. */
544 gdbscm_breakpoint_valid_p (SCM self
)
546 breakpoint_smob
*bp_smob
547 = bpscm_get_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
549 return scm_from_bool (bpscm_is_valid (bp_smob
));
552 /* (breakpoint-enabled? <gdb:breakpoint>) -> boolean */
555 gdbscm_breakpoint_enabled_p (SCM self
)
557 breakpoint_smob
*bp_smob
558 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
560 return scm_from_bool (bp_smob
->bp
->enable_state
== bp_enabled
);
563 /* (set-breakpoint-enabled? <gdb:breakpoint> boolean) -> unspecified */
566 gdbscm_set_breakpoint_enabled_x (SCM self
, SCM newvalue
)
568 breakpoint_smob
*bp_smob
569 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
570 volatile struct gdb_exception except
;
572 SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue
), newvalue
, SCM_ARG2
, FUNC_NAME
,
575 TRY_CATCH (except
, RETURN_MASK_ALL
)
577 if (gdbscm_is_true (newvalue
))
578 enable_breakpoint (bp_smob
->bp
);
580 disable_breakpoint (bp_smob
->bp
);
582 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
584 return SCM_UNSPECIFIED
;
587 /* (breakpoint-silent? <gdb:breakpoint>) -> boolean */
590 gdbscm_breakpoint_silent_p (SCM self
)
592 breakpoint_smob
*bp_smob
593 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
595 return scm_from_bool (bp_smob
->bp
->silent
);
598 /* (set-breakpoint-silent?! <gdb:breakpoint> boolean) -> unspecified */
601 gdbscm_set_breakpoint_silent_x (SCM self
, SCM newvalue
)
603 breakpoint_smob
*bp_smob
604 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
605 volatile struct gdb_exception except
;
607 SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue
), newvalue
, SCM_ARG2
, FUNC_NAME
,
610 TRY_CATCH (except
, RETURN_MASK_ALL
)
612 breakpoint_set_silent (bp_smob
->bp
, gdbscm_is_true (newvalue
));
614 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
616 return SCM_UNSPECIFIED
;
619 /* (breakpoint-ignore-count <gdb:breakpoint>) -> integer */
622 gdbscm_breakpoint_ignore_count (SCM self
)
624 breakpoint_smob
*bp_smob
625 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
627 return scm_from_long (bp_smob
->bp
->ignore_count
);
630 /* (set-breakpoint-ignore-count! <gdb:breakpoint> integer)
634 gdbscm_set_breakpoint_ignore_count_x (SCM self
, SCM newvalue
)
636 breakpoint_smob
*bp_smob
637 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
639 volatile struct gdb_exception except
;
641 SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue
, LONG_MIN
, LONG_MAX
),
642 newvalue
, SCM_ARG2
, FUNC_NAME
, _("integer"));
644 value
= scm_to_long (newvalue
);
648 TRY_CATCH (except
, RETURN_MASK_ALL
)
650 set_ignore_count (bp_smob
->number
, (int) value
, 0);
652 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
654 return SCM_UNSPECIFIED
;
657 /* (breakpoint-hit-count <gdb:breakpoint>) -> integer */
660 gdbscm_breakpoint_hit_count (SCM self
)
662 breakpoint_smob
*bp_smob
663 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
665 return scm_from_long (bp_smob
->bp
->hit_count
);
668 /* (set-breakpoint-hit-count! <gdb:breakpoint> integer) -> unspecified */
671 gdbscm_set_breakpoint_hit_count_x (SCM self
, SCM newvalue
)
673 breakpoint_smob
*bp_smob
674 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
677 SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue
, LONG_MIN
, LONG_MAX
),
678 newvalue
, SCM_ARG2
, FUNC_NAME
, _("integer"));
680 value
= scm_to_long (newvalue
);
686 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG2
, newvalue
,
687 _("hit-count must be zero"));
690 bp_smob
->bp
->hit_count
= 0;
692 return SCM_UNSPECIFIED
;
695 /* (breakpoint-thread <gdb:breakpoint>) -> integer */
698 gdbscm_breakpoint_thread (SCM self
)
700 breakpoint_smob
*bp_smob
701 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
703 if (bp_smob
->bp
->thread
== -1)
706 return scm_from_long (bp_smob
->bp
->thread
);
709 /* (set-breakpoint-thread! <gdb:breakpoint> integer) -> unspecified */
712 gdbscm_set_breakpoint_thread_x (SCM self
, SCM newvalue
)
714 breakpoint_smob
*bp_smob
715 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
718 if (scm_is_signed_integer (newvalue
, LONG_MIN
, LONG_MAX
))
720 id
= scm_to_long (newvalue
);
721 if (! valid_thread_id (id
))
723 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG2
, newvalue
,
724 _("invalid thread id"));
727 else if (gdbscm_is_false (newvalue
))
730 SCM_ASSERT_TYPE (0, newvalue
, SCM_ARG2
, FUNC_NAME
, _("integer or #f"));
732 breakpoint_set_thread (bp_smob
->bp
, id
);
734 return SCM_UNSPECIFIED
;
737 /* (breakpoint-task <gdb:breakpoint>) -> integer */
740 gdbscm_breakpoint_task (SCM self
)
742 breakpoint_smob
*bp_smob
743 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
745 if (bp_smob
->bp
->task
== 0)
748 return scm_from_long (bp_smob
->bp
->task
);
751 /* (set-breakpoint-task! <gdb:breakpoint> integer) -> unspecified */
754 gdbscm_set_breakpoint_task_x (SCM self
, SCM newvalue
)
756 breakpoint_smob
*bp_smob
757 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
760 volatile struct gdb_exception except
;
762 if (scm_is_signed_integer (newvalue
, LONG_MIN
, LONG_MAX
))
764 id
= scm_to_long (newvalue
);
766 TRY_CATCH (except
, RETURN_MASK_ALL
)
768 valid_id
= valid_task_id (id
);
770 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
774 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG2
, newvalue
,
775 _("invalid task id"));
778 else if (gdbscm_is_false (newvalue
))
781 SCM_ASSERT_TYPE (0, newvalue
, SCM_ARG2
, FUNC_NAME
, _("integer or #f"));
783 TRY_CATCH (except
, RETURN_MASK_ALL
)
785 breakpoint_set_task (bp_smob
->bp
, id
);
787 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
789 return SCM_UNSPECIFIED
;
792 /* (breakpoint-location <gdb:breakpoint>) -> string */
795 gdbscm_breakpoint_location (SCM self
)
797 breakpoint_smob
*bp_smob
798 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
801 if (bp_smob
->bp
->type
!= bp_breakpoint
)
804 str
= bp_smob
->bp
->addr_string
;
808 return gdbscm_scm_from_c_string (str
);
811 /* (breakpoint-expression <gdb:breakpoint>) -> string
812 This is only valid for watchpoints.
813 Returns #f for non-watchpoints. */
816 gdbscm_breakpoint_expression (SCM self
)
818 breakpoint_smob
*bp_smob
819 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
821 struct watchpoint
*wp
;
823 if (!is_watchpoint (bp_smob
->bp
))
826 wp
= (struct watchpoint
*) bp_smob
->bp
;
828 str
= wp
->exp_string
;
832 return gdbscm_scm_from_c_string (str
);
835 /* (breakpoint-condition <gdb:breakpoint>) -> string */
838 gdbscm_breakpoint_condition (SCM self
)
840 breakpoint_smob
*bp_smob
841 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
844 str
= bp_smob
->bp
->cond_string
;
848 return gdbscm_scm_from_c_string (str
);
851 /* (set-breakpoint-condition! <gdb:breakpoint> string|#f)
855 gdbscm_set_breakpoint_condition_x (SCM self
, SCM newvalue
)
857 breakpoint_smob
*bp_smob
858 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
860 volatile struct gdb_exception except
;
862 SCM_ASSERT_TYPE (scm_is_string (newvalue
) || gdbscm_is_false (newvalue
),
863 newvalue
, SCM_ARG2
, FUNC_NAME
,
866 if (gdbscm_is_false (newvalue
))
869 exp
= gdbscm_scm_to_c_string (newvalue
);
871 TRY_CATCH (except
, RETURN_MASK_ALL
)
873 set_breakpoint_condition (bp_smob
->bp
, exp
? exp
: "", 0);
876 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
878 return SCM_UNSPECIFIED
;
881 /* (breakpoint-stop <gdb:breakpoint>) -> procedure or #f */
884 gdbscm_breakpoint_stop (SCM self
)
886 breakpoint_smob
*bp_smob
887 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
889 return bp_smob
->stop
;
892 /* (set-breakpoint-stop! <gdb:breakpoint> procedure|#f)
896 gdbscm_set_breakpoint_stop_x (SCM self
, SCM newvalue
)
898 breakpoint_smob
*bp_smob
899 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
900 const struct extension_language_defn
*extlang
= NULL
;
902 SCM_ASSERT_TYPE (gdbscm_is_procedure (newvalue
)
903 || gdbscm_is_false (newvalue
),
904 newvalue
, SCM_ARG2
, FUNC_NAME
,
905 _("procedure or #f"));
907 if (bp_smob
->bp
->cond_string
!= NULL
)
908 extlang
= get_ext_lang_defn (EXT_LANG_GDB
);
910 extlang
= get_breakpoint_cond_ext_lang (bp_smob
->bp
, EXT_LANG_GUILE
);
914 = xstrprintf (_("Only one stop condition allowed. There is"
915 " currently a %s stop condition defined for"
916 " this breakpoint."),
917 ext_lang_capitalized_name (extlang
));
919 scm_dynwind_begin (0);
920 gdbscm_dynwind_xfree (error_text
);
921 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
, error_text
);
922 /* The following line, while unnecessary, is present for completeness
927 bp_smob
->stop
= newvalue
;
929 return SCM_UNSPECIFIED
;
932 /* (breakpoint-commands <gdb:breakpoint>) -> string */
935 gdbscm_breakpoint_commands (SCM self
)
937 breakpoint_smob
*bp_smob
938 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
939 struct breakpoint
*bp
;
941 volatile struct gdb_exception except
;
942 struct ui_file
*string_file
;
943 struct cleanup
*chain
;
949 if (bp
->commands
== NULL
)
952 string_file
= mem_fileopen ();
953 chain
= make_cleanup_ui_file_delete (string_file
);
955 ui_out_redirect (current_uiout
, string_file
);
956 TRY_CATCH (except
, RETURN_MASK_ALL
)
958 print_command_lines (current_uiout
, breakpoint_commands (bp
), 0);
960 ui_out_redirect (current_uiout
, NULL
);
961 if (except
.reason
< 0)
964 gdbscm_throw_gdb_exception (except
);
967 cmdstr
= ui_file_xstrdup (string_file
, &length
);
968 make_cleanup (xfree
, cmdstr
);
969 result
= gdbscm_scm_from_c_string (cmdstr
);
975 /* (breakpoint-type <gdb:breakpoint>) -> integer */
978 gdbscm_breakpoint_type (SCM self
)
980 breakpoint_smob
*bp_smob
981 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
983 return scm_from_long (bp_smob
->bp
->type
);
986 /* (breakpoint-visible? <gdb:breakpoint>) -> boolean */
989 gdbscm_breakpoint_visible (SCM self
)
991 breakpoint_smob
*bp_smob
992 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
994 return scm_from_bool (bp_smob
->bp
->number
>= 0);
997 /* (breakpoint-number <gdb:breakpoint>) -> integer */
1000 gdbscm_breakpoint_number (SCM self
)
1002 breakpoint_smob
*bp_smob
1003 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1005 return scm_from_long (bp_smob
->number
);
1008 /* Return TRUE if "stop" has been set for this breakpoint.
1010 This is the extension_language_ops.breakpoint_has_cond "method". */
1013 gdbscm_breakpoint_has_cond (const struct extension_language_defn
*extlang
,
1014 struct breakpoint
*b
)
1016 breakpoint_smob
*bp_smob
= b
->scm_bp_object
;
1018 if (bp_smob
== NULL
)
1021 return gdbscm_is_procedure (bp_smob
->stop
);
1024 /* Call the "stop" method in the breakpoint class.
1025 This must only be called if gdbscm_breakpoint_has_cond returns true.
1026 If the stop method returns #t, the inferior will be stopped at the
1027 breakpoint. Otherwise the inferior will be allowed to continue
1028 (assuming other conditions don't indicate "stop").
1030 This is the extension_language_ops.breakpoint_cond_says_stop "method". */
1032 enum ext_lang_bp_stop
1033 gdbscm_breakpoint_cond_says_stop
1034 (const struct extension_language_defn
*extlang
, struct breakpoint
*b
)
1036 breakpoint_smob
*bp_smob
= b
->scm_bp_object
;
1037 SCM predicate_result
;
1040 if (bp_smob
== NULL
)
1041 return EXT_LANG_BP_STOP_UNSET
;
1042 if (!gdbscm_is_procedure (bp_smob
->stop
))
1043 return EXT_LANG_BP_STOP_UNSET
;
1048 = gdbscm_safe_call_1 (bp_smob
->stop
, bp_smob
->containing_scm
, NULL
);
1050 if (gdbscm_is_exception (predicate_result
))
1051 ; /* Exception already printed. */
1052 /* If the "stop" function returns #f that means
1053 the Scheme breakpoint wants GDB to continue. */
1054 else if (gdbscm_is_false (predicate_result
))
1057 return stop
? EXT_LANG_BP_STOP_YES
: EXT_LANG_BP_STOP_NO
;
1060 /* Event callback functions. */
1062 /* Callback that is used when a breakpoint is created.
1063 For breakpoints created by Scheme, i.e., gdbscm_create_breakpoint_x, finish
1064 object creation by connecting the Scheme wrapper to the gdb object.
1065 We ignore breakpoints created from gdb or python here, we create the
1066 Scheme wrapper for those when there's a need to, e.g.,
1067 gdbscm_breakpoints. */
1070 bpscm_breakpoint_created (struct breakpoint
*bp
)
1074 if (gdbscm_is_false (pending_breakpoint_scm
))
1077 /* Verify our caller error checked the user's request. */
1078 gdb_assert (bpscm_want_scm_wrapper_p (bp
, 1));
1080 bp_scm
= pending_breakpoint_scm
;
1081 pending_breakpoint_scm
= SCM_BOOL_F
;
1083 bpscm_attach_scm_to_breakpoint (bp
, bp_scm
);
1086 /* Callback that is used when a breakpoint is deleted. This will
1087 invalidate the corresponding Scheme object. */
1090 bpscm_breakpoint_deleted (struct breakpoint
*b
)
1092 int num
= b
->number
;
1093 struct breakpoint
*bp
;
1095 /* TODO: Why the lookup? We have B. */
1097 bp
= get_breakpoint (num
);
1100 breakpoint_smob
*bp_smob
= bp
->scm_bp_object
;
1105 bp_smob
->number
= -1;
1106 bp_smob
->stop
= SCM_BOOL_F
;
1107 scm_gc_unprotect_object (bp_smob
->containing_scm
);
1112 /* Initialize the Scheme breakpoint code. */
1114 static const scheme_integer_constant breakpoint_integer_constants
[] =
1116 { "BP_NONE", bp_none
},
1117 { "BP_BREAKPOINT", bp_breakpoint
},
1118 { "BP_WATCHPOINT", bp_watchpoint
},
1119 { "BP_HARDWARE_WATCHPOINT", bp_hardware_watchpoint
},
1120 { "BP_READ_WATCHPOINT", bp_read_watchpoint
},
1121 { "BP_ACCESS_WATCHPOINT", bp_access_watchpoint
},
1123 { "WP_READ", hw_read
},
1124 { "WP_WRITE", hw_write
},
1125 { "WP_ACCESS", hw_access
},
1127 END_INTEGER_CONSTANTS
1130 static const scheme_function breakpoint_functions
[] =
1132 { "make-breakpoint", 1, 0, 1, gdbscm_make_breakpoint
,
1134 Create a GDB breakpoint object.\n\
1137 location [#:type <type>] [#:wp-class <wp-class>] [#:internal <bool>]\n\
1139 <gdb:breakpoint object" },
1141 { "register-breakpoint!", 1, 0, 0, gdbscm_register_breakpoint_x
,
1143 Register a <gdb:breakpoint> object with GDB." },
1145 { "delete-breakpoint!", 1, 0, 0, gdbscm_delete_breakpoint_x
,
1147 Delete the breakpoint from GDB." },
1149 { "breakpoints", 0, 0, 0, gdbscm_breakpoints
,
1151 Return a list of all GDB breakpoints.\n\
1155 { "breakpoint?", 1, 0, 0, gdbscm_breakpoint_p
,
1157 Return #t if the object is a <gdb:breakpoint> object." },
1159 { "breakpoint-valid?", 1, 0, 0, gdbscm_breakpoint_valid_p
,
1161 Return #t if the breakpoint has not been deleted from GDB." },
1163 { "breakpoint-number", 1, 0, 0, gdbscm_breakpoint_number
,
1165 Return the breakpoint's number." },
1167 { "breakpoint-type", 1, 0, 0, gdbscm_breakpoint_type
,
1169 Return the type of the breakpoint." },
1171 { "breakpoint-visible?", 1, 0, 0, gdbscm_breakpoint_visible
,
1173 Return #t if the breakpoint is visible to the user." },
1175 { "breakpoint-location", 1, 0, 0, gdbscm_breakpoint_location
,
1177 Return the location of the breakpoint as specified by the user." },
1179 { "breakpoint-expression", 1, 0, 0, gdbscm_breakpoint_expression
,
1181 Return the expression of the breakpoint as specified by the user.\n\
1182 Valid for watchpoints only, returns #f for non-watchpoints." },
1184 { "breakpoint-enabled?", 1, 0, 0, gdbscm_breakpoint_enabled_p
,
1186 Return #t if the breakpoint is enabled." },
1188 { "set-breakpoint-enabled!", 2, 0, 0, gdbscm_set_breakpoint_enabled_x
,
1190 Set the breakpoint's enabled state.\n\
1192 Arguments: <gdb:breakpoint> boolean" },
1194 { "breakpoint-silent?", 1, 0, 0, gdbscm_breakpoint_silent_p
,
1196 Return #t if the breakpoint is silent." },
1198 { "set-breakpoint-silent!", 2, 0, 0, gdbscm_set_breakpoint_silent_x
,
1200 Set the breakpoint's silent state.\n\
1202 Arguments: <gdb:breakpoint> boolean" },
1204 { "breakpoint-ignore-count", 1, 0, 0, gdbscm_breakpoint_ignore_count
,
1206 Return the breakpoint's \"ignore\" count." },
1208 { "set-breakpoint-ignore-count!", 2, 0, 0,
1209 gdbscm_set_breakpoint_ignore_count_x
,
1211 Set the breakpoint's \"ignore\" count.\n\
1213 Arguments: <gdb:breakpoint> count" },
1215 { "breakpoint-hit-count", 1, 0, 0, gdbscm_breakpoint_hit_count
,
1217 Return the breakpoint's \"hit\" count." },
1219 { "set-breakpoint-hit-count!", 2, 0, 0, gdbscm_set_breakpoint_hit_count_x
,
1221 Set the breakpoint's \"hit\" count. The value must be zero.\n\
1223 Arguments: <gdb:breakpoint> 0" },
1225 { "breakpoint-thread", 1, 0, 0, gdbscm_breakpoint_thread
,
1227 Return the breakpoint's thread id or #f if there isn't one." },
1229 { "set-breakpoint-thread!", 2, 0, 0, gdbscm_set_breakpoint_thread_x
,
1231 Set the thread id for this breakpoint.\n\
1233 Arguments: <gdb:breakpoint> thread-id" },
1235 { "breakpoint-task", 1, 0, 0, gdbscm_breakpoint_task
,
1237 Return the breakpoint's Ada task-id or #f if there isn't one." },
1239 { "set-breakpoint-task!", 2, 0, 0, gdbscm_set_breakpoint_task_x
,
1241 Set the breakpoint's Ada task-id.\n\
1243 Arguments: <gdb:breakpoint> task-id" },
1245 { "breakpoint-condition", 1, 0, 0, gdbscm_breakpoint_condition
,
1247 Return the breakpoint's condition as specified by the user.\n\
1248 Return #f if there isn't one." },
1250 { "set-breakpoint-condition!", 2, 0, 0, gdbscm_set_breakpoint_condition_x
,
1252 Set the breakpoint's condition.\n\
1254 Arguments: <gdb:breakpoint> condition\n\
1255 condition: a string" },
1257 { "breakpoint-stop", 1, 0, 0, gdbscm_breakpoint_stop
,
1259 Return the breakpoint's stop predicate.\n\
1260 Return #f if there isn't one." },
1262 { "set-breakpoint-stop!", 2, 0, 0, gdbscm_set_breakpoint_stop_x
,
1264 Set the breakpoint's stop predicate.\n\
1266 Arguments: <gdb:breakpoint> procedure\n\
1267 procedure: A procedure of one argument, the breakpoint.\n\
1268 Its result is true if program execution should stop." },
1270 { "breakpoint-commands", 1, 0, 0, gdbscm_breakpoint_commands
,
1272 Return the breakpoint's commands." },
1278 gdbscm_initialize_breakpoints (void)
1281 = gdbscm_make_smob_type (breakpoint_smob_name
, sizeof (breakpoint_smob
));
1282 scm_set_smob_free (breakpoint_smob_tag
, bpscm_free_breakpoint_smob
);
1283 scm_set_smob_print (breakpoint_smob_tag
, bpscm_print_breakpoint_smob
);
1285 observer_attach_breakpoint_created (bpscm_breakpoint_created
);
1286 observer_attach_breakpoint_deleted (bpscm_breakpoint_deleted
);
1288 gdbscm_define_integer_constants (breakpoint_integer_constants
, 1);
1289 gdbscm_define_functions (breakpoint_functions
, 1);
1291 type_keyword
= scm_from_latin1_keyword ("type");
1292 wp_class_keyword
= scm_from_latin1_keyword ("wp-class");
1293 internal_keyword
= scm_from_latin1_keyword ("internal");