1 /* Scheme interface to breakpoints.
3 Copyright (C) 2008-2016 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 "breakpoint.h"
27 #include "gdbthread.h"
29 #include "cli/cli-script.h"
31 #include "arch-utils.h"
33 #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 default: return "unknown";
159 /* The smob "print" function for <gdb:breakpoint>. */
162 bpscm_print_breakpoint_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
164 breakpoint_smob
*bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (self
);
165 struct breakpoint
*b
= bp_smob
->bp
;
167 gdbscm_printf (port
, "#<%s", breakpoint_smob_name
);
169 /* Only print what we export to the user.
170 The rest are possibly internal implementation details. */
172 gdbscm_printf (port
, " #%d", bp_smob
->number
);
174 /* Careful, the breakpoint may be invalid. */
179 gdbscm_printf (port
, " %s %s %s",
180 bpscm_type_to_string (b
->type
),
181 bpscm_enable_state_to_string (b
->enable_state
),
182 b
->silent
? "silent" : "noisy");
184 gdbscm_printf (port
, " hit:%d", b
->hit_count
);
185 gdbscm_printf (port
, " ignore:%d", b
->ignore_count
);
187 str
= event_location_to_string (b
->location
);
189 gdbscm_printf (port
, " @%s", str
);
192 scm_puts (">", port
);
194 scm_remember_upto_here_1 (self
);
196 /* Non-zero means success. */
200 /* Low level routine to create a <gdb:breakpoint> object. */
203 bpscm_make_breakpoint_smob (void)
205 breakpoint_smob
*bp_smob
= (breakpoint_smob
*)
206 scm_gc_malloc (sizeof (breakpoint_smob
), breakpoint_smob_name
);
209 memset (bp_smob
, 0, sizeof (*bp_smob
));
210 bp_smob
->number
= -1;
211 bp_smob
->stop
= SCM_BOOL_F
;
212 bp_scm
= scm_new_smob (breakpoint_smob_tag
, (scm_t_bits
) bp_smob
);
213 bp_smob
->containing_scm
= bp_scm
;
214 gdbscm_init_gsmob (&bp_smob
->base
);
219 /* Return non-zero if we want a Scheme wrapper for breakpoint B.
220 If FROM_SCHEME is non-zero,this is called for a breakpoint created
221 by the user from Scheme. Otherwise it is zero. */
224 bpscm_want_scm_wrapper_p (struct breakpoint
*bp
, int from_scheme
)
226 /* Don't create <gdb:breakpoint> objects for internal GDB breakpoints. */
227 if (bp
->number
< 0 && !from_scheme
)
230 /* The others are not supported. */
231 if (bp
->type
!= bp_breakpoint
232 && bp
->type
!= bp_watchpoint
233 && bp
->type
!= bp_hardware_watchpoint
234 && bp
->type
!= bp_read_watchpoint
235 && bp
->type
!= bp_access_watchpoint
)
241 /* Install the Scheme side of a breakpoint, CONTAINING_SCM, in
245 bpscm_attach_scm_to_breakpoint (struct breakpoint
*bp
, SCM containing_scm
)
247 breakpoint_smob
*bp_smob
;
249 bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (containing_scm
);
250 bp_smob
->number
= bp
->number
;
252 bp_smob
->containing_scm
= containing_scm
;
253 bp_smob
->bp
->scm_bp_object
= bp_smob
;
255 /* The owner of this breakpoint is not in GC-controlled memory, so we need
256 to protect it from GC until the breakpoint is deleted. */
257 scm_gc_protect_object (containing_scm
);
260 /* Return non-zero if SCM is a breakpoint smob. */
263 bpscm_is_breakpoint (SCM scm
)
265 return SCM_SMOB_PREDICATE (breakpoint_smob_tag
, scm
);
268 /* (breakpoint? scm) -> boolean */
271 gdbscm_breakpoint_p (SCM scm
)
273 return scm_from_bool (bpscm_is_breakpoint (scm
));
276 /* Returns the <gdb:breakpoint> object in SELF.
277 Throws an exception if SELF is not a <gdb:breakpoint> object. */
280 bpscm_get_breakpoint_arg_unsafe (SCM self
, int arg_pos
, const char *func_name
)
282 SCM_ASSERT_TYPE (bpscm_is_breakpoint (self
), self
, arg_pos
, func_name
,
283 breakpoint_smob_name
);
288 /* Returns a pointer to the breakpoint smob of SELF.
289 Throws an exception if SELF is not a <gdb:breakpoint> object. */
291 static breakpoint_smob
*
292 bpscm_get_breakpoint_smob_arg_unsafe (SCM self
, int arg_pos
,
293 const char *func_name
)
295 SCM bp_scm
= bpscm_get_breakpoint_arg_unsafe (self
, arg_pos
, func_name
);
296 breakpoint_smob
*bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (bp_scm
);
301 /* Return non-zero if breakpoint BP_SMOB is valid. */
304 bpscm_is_valid (breakpoint_smob
*bp_smob
)
306 return bp_smob
->bp
!= NULL
;
309 /* Returns the breakpoint smob in SELF, verifying it's valid.
310 Throws an exception if SELF is not a <gdb:breakpoint> object,
313 static breakpoint_smob
*
314 bpscm_get_valid_breakpoint_smob_arg_unsafe (SCM self
, int arg_pos
,
315 const char *func_name
)
317 breakpoint_smob
*bp_smob
318 = bpscm_get_breakpoint_smob_arg_unsafe (self
, arg_pos
, func_name
);
320 if (!bpscm_is_valid (bp_smob
))
322 gdbscm_invalid_object_error (func_name
, arg_pos
, self
,
323 _("<gdb:breakpoint>"));
329 /* Breakpoint methods. */
331 /* (make-breakpoint string [#:type integer] [#:wp-class integer]
332 [#:internal boolean) -> <gdb:breakpoint>
334 The result is the <gdb:breakpoint> Scheme object.
335 The breakpoint is not available to be used yet, however.
336 It must still be added to gdb with register-breakpoint!. */
339 gdbscm_make_breakpoint (SCM location_scm
, SCM rest
)
341 const SCM keywords
[] = {
342 type_keyword
, wp_class_keyword
, internal_keyword
, SCM_BOOL_F
346 int type_arg_pos
= -1, access_type_arg_pos
= -1, internal_arg_pos
= -1;
347 enum bptype type
= bp_breakpoint
;
348 enum target_hw_bp_type access_type
= hw_write
;
351 breakpoint_smob
*bp_smob
;
353 gdbscm_parse_function_args (FUNC_NAME
, SCM_ARG1
, keywords
, "s#iit",
354 location_scm
, &location
, rest
,
355 &type_arg_pos
, &type
,
356 &access_type_arg_pos
, &access_type
,
357 &internal_arg_pos
, &internal
);
359 result
= bpscm_make_breakpoint_smob ();
360 bp_smob
= (breakpoint_smob
*) SCM_SMOB_DATA (result
);
363 location
= gdbscm_gc_xstrdup (s
);
369 if (access_type_arg_pos
> 0)
371 gdbscm_misc_error (FUNC_NAME
, access_type_arg_pos
,
372 scm_from_int (access_type
),
373 _("access type with breakpoint is not allowed"));
384 gdbscm_out_of_range_error (FUNC_NAME
, access_type_arg_pos
,
385 scm_from_int (access_type
),
386 _("invalid watchpoint class"));
390 gdbscm_out_of_range_error (FUNC_NAME
, access_type_arg_pos
,
392 _("invalid breakpoint type"));
395 bp_smob
->is_scheme_bkpt
= 1;
396 bp_smob
->spec
.location
= location
;
397 bp_smob
->spec
.type
= type
;
398 bp_smob
->spec
.access_type
= access_type
;
399 bp_smob
->spec
.is_internal
= internal
;
404 /* (register-breakpoint! <gdb:breakpoint>) -> unspecified
406 It is an error to register a breakpoint created outside of Guile,
407 or an already-registered breakpoint. */
410 gdbscm_register_breakpoint_x (SCM self
)
412 breakpoint_smob
*bp_smob
413 = bpscm_get_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
414 struct gdb_exception except
= exception_none
;
415 char *location
, *copy
;
416 struct event_location
*eloc
;
417 struct cleanup
*cleanup
;
419 /* We only support registering breakpoints created with make-breakpoint. */
420 if (!bp_smob
->is_scheme_bkpt
)
421 scm_misc_error (FUNC_NAME
, _("not a Scheme breakpoint"), SCM_EOL
);
423 if (bpscm_is_valid (bp_smob
))
424 scm_misc_error (FUNC_NAME
, _("breakpoint is already registered"), SCM_EOL
);
426 pending_breakpoint_scm
= self
;
427 location
= bp_smob
->spec
.location
;
428 copy
= skip_spaces (location
);
429 eloc
= string_to_event_location_basic (©
, current_language
);
430 cleanup
= make_cleanup_delete_event_location (eloc
);
434 int internal
= bp_smob
->spec
.is_internal
;
436 switch (bp_smob
->spec
.type
)
440 create_breakpoint (get_current_arch (),
441 eloc
, NULL
, -1, NULL
,
446 &bkpt_breakpoint_ops
,
452 enum target_hw_bp_type access_type
= bp_smob
->spec
.access_type
;
454 if (access_type
== hw_write
)
455 watch_command_wrapper (location
, 0, internal
);
456 else if (access_type
== hw_access
)
457 awatch_command_wrapper (location
, 0, internal
);
458 else if (access_type
== hw_read
)
459 rwatch_command_wrapper (location
, 0, internal
);
461 gdb_assert_not_reached ("invalid access type");
465 gdb_assert_not_reached ("invalid breakpoint type");
468 CATCH (ex
, RETURN_MASK_ALL
)
474 /* Ensure this gets reset, even if there's an error. */
475 pending_breakpoint_scm
= SCM_BOOL_F
;
476 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
477 do_cleanups (cleanup
);
479 return SCM_UNSPECIFIED
;
482 /* (delete-breakpoint! <gdb:breakpoint>) -> unspecified
483 Scheme function which deletes (removes) the underlying GDB breakpoint
484 from GDB's list of breakpoints. This triggers the breakpoint_deleted
485 observer which will call gdbscm_breakpoint_deleted; that function cleans
486 up the Scheme bits. */
489 gdbscm_delete_breakpoint_x (SCM self
)
491 breakpoint_smob
*bp_smob
492 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
496 delete_breakpoint (bp_smob
->bp
);
498 CATCH (except
, RETURN_MASK_ALL
)
500 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
504 return SCM_UNSPECIFIED
;
507 /* iterate_over_breakpoints function for gdbscm_breakpoints. */
510 bpscm_build_bp_list (struct breakpoint
*bp
, void *arg
)
512 SCM
*list
= (SCM
*) arg
;
513 breakpoint_smob
*bp_smob
= bp
->scm_bp_object
;
515 /* Lazily create wrappers for breakpoints created outside Scheme. */
519 if (bpscm_want_scm_wrapper_p (bp
, 0))
523 bp_scm
= bpscm_make_breakpoint_smob ();
524 bpscm_attach_scm_to_breakpoint (bp
, bp_scm
);
526 bp_smob
= bp
->scm_bp_object
;
530 /* Not all breakpoints will have a companion Scheme object.
531 Only breakpoints that trigger the created_breakpoint observer call,
532 and satisfy certain conditions (see bpscm_want_scm_wrapper_p),
533 get a companion object (this includes Scheme-created breakpoints). */
536 *list
= scm_cons (bp_smob
->containing_scm
, *list
);
541 /* (breakpoints) -> list
542 Return a list of all breakpoints. */
545 gdbscm_breakpoints (void)
549 /* If iterate_over_breakpoints returns non-NULL it means the iteration
551 In that case abandon building the list and return #f. */
552 if (iterate_over_breakpoints (bpscm_build_bp_list
, &list
) != NULL
)
555 return scm_reverse_x (list
, SCM_EOL
);
558 /* (breakpoint-valid? <gdb:breakpoint>) -> boolean
559 Returns #t if SELF is still valid. */
562 gdbscm_breakpoint_valid_p (SCM self
)
564 breakpoint_smob
*bp_smob
565 = bpscm_get_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
567 return scm_from_bool (bpscm_is_valid (bp_smob
));
570 /* (breakpoint-enabled? <gdb:breakpoint>) -> boolean */
573 gdbscm_breakpoint_enabled_p (SCM self
)
575 breakpoint_smob
*bp_smob
576 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
578 return scm_from_bool (bp_smob
->bp
->enable_state
== bp_enabled
);
581 /* (set-breakpoint-enabled? <gdb:breakpoint> boolean) -> unspecified */
584 gdbscm_set_breakpoint_enabled_x (SCM self
, SCM newvalue
)
586 breakpoint_smob
*bp_smob
587 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
589 SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue
), newvalue
, SCM_ARG2
, FUNC_NAME
,
594 if (gdbscm_is_true (newvalue
))
595 enable_breakpoint (bp_smob
->bp
);
597 disable_breakpoint (bp_smob
->bp
);
599 CATCH (except
, RETURN_MASK_ALL
)
601 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
605 return SCM_UNSPECIFIED
;
608 /* (breakpoint-silent? <gdb:breakpoint>) -> boolean */
611 gdbscm_breakpoint_silent_p (SCM self
)
613 breakpoint_smob
*bp_smob
614 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
616 return scm_from_bool (bp_smob
->bp
->silent
);
619 /* (set-breakpoint-silent?! <gdb:breakpoint> boolean) -> unspecified */
622 gdbscm_set_breakpoint_silent_x (SCM self
, SCM newvalue
)
624 breakpoint_smob
*bp_smob
625 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
627 SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue
), newvalue
, SCM_ARG2
, FUNC_NAME
,
632 breakpoint_set_silent (bp_smob
->bp
, gdbscm_is_true (newvalue
));
634 CATCH (except
, RETURN_MASK_ALL
)
636 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
640 return SCM_UNSPECIFIED
;
643 /* (breakpoint-ignore-count <gdb:breakpoint>) -> integer */
646 gdbscm_breakpoint_ignore_count (SCM self
)
648 breakpoint_smob
*bp_smob
649 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
651 return scm_from_long (bp_smob
->bp
->ignore_count
);
654 /* (set-breakpoint-ignore-count! <gdb:breakpoint> integer)
658 gdbscm_set_breakpoint_ignore_count_x (SCM self
, SCM newvalue
)
660 breakpoint_smob
*bp_smob
661 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
664 SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue
, LONG_MIN
, LONG_MAX
),
665 newvalue
, SCM_ARG2
, FUNC_NAME
, _("integer"));
667 value
= scm_to_long (newvalue
);
673 set_ignore_count (bp_smob
->number
, (int) value
, 0);
675 CATCH (except
, RETURN_MASK_ALL
)
677 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
681 return SCM_UNSPECIFIED
;
684 /* (breakpoint-hit-count <gdb:breakpoint>) -> integer */
687 gdbscm_breakpoint_hit_count (SCM self
)
689 breakpoint_smob
*bp_smob
690 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
692 return scm_from_long (bp_smob
->bp
->hit_count
);
695 /* (set-breakpoint-hit-count! <gdb:breakpoint> integer) -> unspecified */
698 gdbscm_set_breakpoint_hit_count_x (SCM self
, SCM newvalue
)
700 breakpoint_smob
*bp_smob
701 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
704 SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue
, LONG_MIN
, LONG_MAX
),
705 newvalue
, SCM_ARG2
, FUNC_NAME
, _("integer"));
707 value
= scm_to_long (newvalue
);
713 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG2
, newvalue
,
714 _("hit-count must be zero"));
717 bp_smob
->bp
->hit_count
= 0;
719 return SCM_UNSPECIFIED
;
722 /* (breakpoint-thread <gdb:breakpoint>) -> integer */
725 gdbscm_breakpoint_thread (SCM self
)
727 breakpoint_smob
*bp_smob
728 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
730 if (bp_smob
->bp
->thread
== -1)
733 return scm_from_long (bp_smob
->bp
->thread
);
736 /* (set-breakpoint-thread! <gdb:breakpoint> integer) -> unspecified */
739 gdbscm_set_breakpoint_thread_x (SCM self
, SCM newvalue
)
741 breakpoint_smob
*bp_smob
742 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
745 if (scm_is_signed_integer (newvalue
, LONG_MIN
, LONG_MAX
))
747 id
= scm_to_long (newvalue
);
748 if (!valid_global_thread_id (id
))
750 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG2
, newvalue
,
751 _("invalid thread id"));
754 else if (gdbscm_is_false (newvalue
))
757 SCM_ASSERT_TYPE (0, newvalue
, SCM_ARG2
, FUNC_NAME
, _("integer or #f"));
759 breakpoint_set_thread (bp_smob
->bp
, id
);
761 return SCM_UNSPECIFIED
;
764 /* (breakpoint-task <gdb:breakpoint>) -> integer */
767 gdbscm_breakpoint_task (SCM self
)
769 breakpoint_smob
*bp_smob
770 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
772 if (bp_smob
->bp
->task
== 0)
775 return scm_from_long (bp_smob
->bp
->task
);
778 /* (set-breakpoint-task! <gdb:breakpoint> integer) -> unspecified */
781 gdbscm_set_breakpoint_task_x (SCM self
, SCM newvalue
)
783 breakpoint_smob
*bp_smob
784 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
788 if (scm_is_signed_integer (newvalue
, LONG_MIN
, LONG_MAX
))
790 id
= scm_to_long (newvalue
);
794 valid_id
= valid_task_id (id
);
796 CATCH (except
, RETURN_MASK_ALL
)
798 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
804 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG2
, newvalue
,
805 _("invalid task id"));
808 else if (gdbscm_is_false (newvalue
))
811 SCM_ASSERT_TYPE (0, newvalue
, SCM_ARG2
, FUNC_NAME
, _("integer or #f"));
815 breakpoint_set_task (bp_smob
->bp
, id
);
817 CATCH (except
, RETURN_MASK_ALL
)
819 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
823 return SCM_UNSPECIFIED
;
826 /* (breakpoint-location <gdb:breakpoint>) -> string */
829 gdbscm_breakpoint_location (SCM self
)
831 breakpoint_smob
*bp_smob
832 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
835 if (bp_smob
->bp
->type
!= bp_breakpoint
)
838 str
= event_location_to_string (bp_smob
->bp
->location
);
842 return gdbscm_scm_from_c_string (str
);
845 /* (breakpoint-expression <gdb:breakpoint>) -> string
846 This is only valid for watchpoints.
847 Returns #f for non-watchpoints. */
850 gdbscm_breakpoint_expression (SCM self
)
852 breakpoint_smob
*bp_smob
853 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
855 struct watchpoint
*wp
;
857 if (!is_watchpoint (bp_smob
->bp
))
860 wp
= (struct watchpoint
*) bp_smob
->bp
;
862 str
= wp
->exp_string
;
866 return gdbscm_scm_from_c_string (str
);
869 /* (breakpoint-condition <gdb:breakpoint>) -> string */
872 gdbscm_breakpoint_condition (SCM self
)
874 breakpoint_smob
*bp_smob
875 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
878 str
= bp_smob
->bp
->cond_string
;
882 return gdbscm_scm_from_c_string (str
);
885 /* (set-breakpoint-condition! <gdb:breakpoint> string|#f)
889 gdbscm_set_breakpoint_condition_x (SCM self
, SCM newvalue
)
891 breakpoint_smob
*bp_smob
892 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
894 struct gdb_exception except
= exception_none
;
896 SCM_ASSERT_TYPE (scm_is_string (newvalue
) || gdbscm_is_false (newvalue
),
897 newvalue
, SCM_ARG2
, FUNC_NAME
,
900 if (gdbscm_is_false (newvalue
))
903 exp
= gdbscm_scm_to_c_string (newvalue
);
907 set_breakpoint_condition (bp_smob
->bp
, exp
? exp
: "", 0);
909 CATCH (ex
, RETURN_MASK_ALL
)
916 GDBSCM_HANDLE_GDB_EXCEPTION (except
);
918 return SCM_UNSPECIFIED
;
921 /* (breakpoint-stop <gdb:breakpoint>) -> procedure or #f */
924 gdbscm_breakpoint_stop (SCM self
)
926 breakpoint_smob
*bp_smob
927 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
929 return bp_smob
->stop
;
932 /* (set-breakpoint-stop! <gdb:breakpoint> procedure|#f)
936 gdbscm_set_breakpoint_stop_x (SCM self
, SCM newvalue
)
938 breakpoint_smob
*bp_smob
939 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
940 const struct extension_language_defn
*extlang
= NULL
;
942 SCM_ASSERT_TYPE (gdbscm_is_procedure (newvalue
)
943 || gdbscm_is_false (newvalue
),
944 newvalue
, SCM_ARG2
, FUNC_NAME
,
945 _("procedure or #f"));
947 if (bp_smob
->bp
->cond_string
!= NULL
)
948 extlang
= get_ext_lang_defn (EXT_LANG_GDB
);
950 extlang
= get_breakpoint_cond_ext_lang (bp_smob
->bp
, EXT_LANG_GUILE
);
954 = xstrprintf (_("Only one stop condition allowed. There is"
955 " currently a %s stop condition defined for"
956 " this breakpoint."),
957 ext_lang_capitalized_name (extlang
));
959 scm_dynwind_begin ((scm_t_dynwind_flags
) 0);
960 gdbscm_dynwind_xfree (error_text
);
961 gdbscm_out_of_range_error (FUNC_NAME
, SCM_ARG1
, self
, error_text
);
962 /* The following line, while unnecessary, is present for completeness
967 bp_smob
->stop
= newvalue
;
969 return SCM_UNSPECIFIED
;
972 /* (breakpoint-commands <gdb:breakpoint>) -> string */
975 gdbscm_breakpoint_commands (SCM self
)
977 breakpoint_smob
*bp_smob
978 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
979 struct breakpoint
*bp
;
981 struct ui_file
*string_file
;
982 struct cleanup
*chain
;
987 if (bp
->commands
== NULL
)
990 string_file
= mem_fileopen ();
991 chain
= make_cleanup_ui_file_delete (string_file
);
993 ui_out_redirect (current_uiout
, string_file
);
996 print_command_lines (current_uiout
, breakpoint_commands (bp
), 0);
998 ui_out_redirect (current_uiout
, NULL
);
999 CATCH (except
, RETURN_MASK_ALL
)
1001 do_cleanups (chain
);
1002 gdbscm_throw_gdb_exception (except
);
1006 std::string cmdstr
= ui_file_as_string (string_file
);
1007 result
= gdbscm_scm_from_c_string (cmdstr
.c_str ());
1009 do_cleanups (chain
);
1013 /* (breakpoint-type <gdb:breakpoint>) -> integer */
1016 gdbscm_breakpoint_type (SCM self
)
1018 breakpoint_smob
*bp_smob
1019 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1021 return scm_from_long (bp_smob
->bp
->type
);
1024 /* (breakpoint-visible? <gdb:breakpoint>) -> boolean */
1027 gdbscm_breakpoint_visible (SCM self
)
1029 breakpoint_smob
*bp_smob
1030 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1032 return scm_from_bool (bp_smob
->bp
->number
>= 0);
1035 /* (breakpoint-number <gdb:breakpoint>) -> integer */
1038 gdbscm_breakpoint_number (SCM self
)
1040 breakpoint_smob
*bp_smob
1041 = bpscm_get_valid_breakpoint_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
1043 return scm_from_long (bp_smob
->number
);
1046 /* Return TRUE if "stop" has been set for this breakpoint.
1048 This is the extension_language_ops.breakpoint_has_cond "method". */
1051 gdbscm_breakpoint_has_cond (const struct extension_language_defn
*extlang
,
1052 struct breakpoint
*b
)
1054 breakpoint_smob
*bp_smob
= b
->scm_bp_object
;
1056 if (bp_smob
== NULL
)
1059 return gdbscm_is_procedure (bp_smob
->stop
);
1062 /* Call the "stop" method in the breakpoint class.
1063 This must only be called if gdbscm_breakpoint_has_cond returns true.
1064 If the stop method returns #t, the inferior will be stopped at the
1065 breakpoint. Otherwise the inferior will be allowed to continue
1066 (assuming other conditions don't indicate "stop").
1068 This is the extension_language_ops.breakpoint_cond_says_stop "method". */
1070 enum ext_lang_bp_stop
1071 gdbscm_breakpoint_cond_says_stop
1072 (const struct extension_language_defn
*extlang
, struct breakpoint
*b
)
1074 breakpoint_smob
*bp_smob
= b
->scm_bp_object
;
1075 SCM predicate_result
;
1078 if (bp_smob
== NULL
)
1079 return EXT_LANG_BP_STOP_UNSET
;
1080 if (!gdbscm_is_procedure (bp_smob
->stop
))
1081 return EXT_LANG_BP_STOP_UNSET
;
1086 = gdbscm_safe_call_1 (bp_smob
->stop
, bp_smob
->containing_scm
, NULL
);
1088 if (gdbscm_is_exception (predicate_result
))
1089 ; /* Exception already printed. */
1090 /* If the "stop" function returns #f that means
1091 the Scheme breakpoint wants GDB to continue. */
1092 else if (gdbscm_is_false (predicate_result
))
1095 return stop
? EXT_LANG_BP_STOP_YES
: EXT_LANG_BP_STOP_NO
;
1098 /* Event callback functions. */
1100 /* Callback that is used when a breakpoint is created.
1101 For breakpoints created by Scheme, i.e., gdbscm_create_breakpoint_x, finish
1102 object creation by connecting the Scheme wrapper to the gdb object.
1103 We ignore breakpoints created from gdb or python here, we create the
1104 Scheme wrapper for those when there's a need to, e.g.,
1105 gdbscm_breakpoints. */
1108 bpscm_breakpoint_created (struct breakpoint
*bp
)
1112 if (gdbscm_is_false (pending_breakpoint_scm
))
1115 /* Verify our caller error checked the user's request. */
1116 gdb_assert (bpscm_want_scm_wrapper_p (bp
, 1));
1118 bp_scm
= pending_breakpoint_scm
;
1119 pending_breakpoint_scm
= SCM_BOOL_F
;
1121 bpscm_attach_scm_to_breakpoint (bp
, bp_scm
);
1124 /* Callback that is used when a breakpoint is deleted. This will
1125 invalidate the corresponding Scheme object. */
1128 bpscm_breakpoint_deleted (struct breakpoint
*b
)
1130 int num
= b
->number
;
1131 struct breakpoint
*bp
;
1133 /* TODO: Why the lookup? We have B. */
1135 bp
= get_breakpoint (num
);
1138 breakpoint_smob
*bp_smob
= bp
->scm_bp_object
;
1143 bp_smob
->number
= -1;
1144 bp_smob
->stop
= SCM_BOOL_F
;
1145 scm_gc_unprotect_object (bp_smob
->containing_scm
);
1150 /* Initialize the Scheme breakpoint code. */
1152 static const scheme_integer_constant breakpoint_integer_constants
[] =
1154 { "BP_NONE", bp_none
},
1155 { "BP_BREAKPOINT", bp_breakpoint
},
1156 { "BP_WATCHPOINT", bp_watchpoint
},
1157 { "BP_HARDWARE_WATCHPOINT", bp_hardware_watchpoint
},
1158 { "BP_READ_WATCHPOINT", bp_read_watchpoint
},
1159 { "BP_ACCESS_WATCHPOINT", bp_access_watchpoint
},
1161 { "WP_READ", hw_read
},
1162 { "WP_WRITE", hw_write
},
1163 { "WP_ACCESS", hw_access
},
1165 END_INTEGER_CONSTANTS
1168 static const scheme_function breakpoint_functions
[] =
1170 { "make-breakpoint", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_breakpoint
),
1172 Create a GDB breakpoint object.\n\
1175 location [#:type <type>] [#:wp-class <wp-class>] [#:internal <bool>]\n\
1177 <gdb:breakpoint object" },
1179 { "register-breakpoint!", 1, 0, 0,
1180 as_a_scm_t_subr (gdbscm_register_breakpoint_x
),
1182 Register a <gdb:breakpoint> object with GDB." },
1184 { "delete-breakpoint!", 1, 0, 0, as_a_scm_t_subr (gdbscm_delete_breakpoint_x
),
1186 Delete the breakpoint from GDB." },
1188 { "breakpoints", 0, 0, 0, as_a_scm_t_subr (gdbscm_breakpoints
),
1190 Return a list of all GDB breakpoints.\n\
1194 { "breakpoint?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_p
),
1196 Return #t if the object is a <gdb:breakpoint> object." },
1198 { "breakpoint-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_valid_p
),
1200 Return #t if the breakpoint has not been deleted from GDB." },
1202 { "breakpoint-number", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_number
),
1204 Return the breakpoint's number." },
1206 { "breakpoint-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_type
),
1208 Return the type of the breakpoint." },
1210 { "breakpoint-visible?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_visible
),
1212 Return #t if the breakpoint is visible to the user." },
1214 { "breakpoint-location", 1, 0, 0,
1215 as_a_scm_t_subr (gdbscm_breakpoint_location
),
1217 Return the location of the breakpoint as specified by the user." },
1219 { "breakpoint-expression", 1, 0, 0,
1220 as_a_scm_t_subr (gdbscm_breakpoint_expression
),
1222 Return the expression of the breakpoint as specified by the user.\n\
1223 Valid for watchpoints only, returns #f for non-watchpoints." },
1225 { "breakpoint-enabled?", 1, 0, 0,
1226 as_a_scm_t_subr (gdbscm_breakpoint_enabled_p
),
1228 Return #t if the breakpoint is enabled." },
1230 { "set-breakpoint-enabled!", 2, 0, 0,
1231 as_a_scm_t_subr (gdbscm_set_breakpoint_enabled_x
),
1233 Set the breakpoint's enabled state.\n\
1235 Arguments: <gdb:breakpoint> boolean" },
1237 { "breakpoint-silent?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_silent_p
),
1239 Return #t if the breakpoint is silent." },
1241 { "set-breakpoint-silent!", 2, 0, 0,
1242 as_a_scm_t_subr (gdbscm_set_breakpoint_silent_x
),
1244 Set the breakpoint's silent state.\n\
1246 Arguments: <gdb:breakpoint> boolean" },
1248 { "breakpoint-ignore-count", 1, 0, 0,
1249 as_a_scm_t_subr (gdbscm_breakpoint_ignore_count
),
1251 Return the breakpoint's \"ignore\" count." },
1253 { "set-breakpoint-ignore-count!", 2, 0, 0,
1254 as_a_scm_t_subr (gdbscm_set_breakpoint_ignore_count_x
),
1256 Set the breakpoint's \"ignore\" count.\n\
1258 Arguments: <gdb:breakpoint> count" },
1260 { "breakpoint-hit-count", 1, 0, 0,
1261 as_a_scm_t_subr (gdbscm_breakpoint_hit_count
),
1263 Return the breakpoint's \"hit\" count." },
1265 { "set-breakpoint-hit-count!", 2, 0, 0,
1266 as_a_scm_t_subr (gdbscm_set_breakpoint_hit_count_x
),
1268 Set the breakpoint's \"hit\" count. The value must be zero.\n\
1270 Arguments: <gdb:breakpoint> 0" },
1272 { "breakpoint-thread", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_thread
),
1274 Return the breakpoint's global thread id or #f if there isn't one." },
1276 { "set-breakpoint-thread!", 2, 0, 0,
1277 as_a_scm_t_subr (gdbscm_set_breakpoint_thread_x
),
1279 Set the global thread id for this breakpoint.\n\
1281 Arguments: <gdb:breakpoint> global-thread-id" },
1283 { "breakpoint-task", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_task
),
1285 Return the breakpoint's Ada task-id or #f if there isn't one." },
1287 { "set-breakpoint-task!", 2, 0, 0,
1288 as_a_scm_t_subr (gdbscm_set_breakpoint_task_x
),
1290 Set the breakpoint's Ada task-id.\n\
1292 Arguments: <gdb:breakpoint> task-id" },
1294 { "breakpoint-condition", 1, 0, 0,
1295 as_a_scm_t_subr (gdbscm_breakpoint_condition
),
1297 Return the breakpoint's condition as specified by the user.\n\
1298 Return #f if there isn't one." },
1300 { "set-breakpoint-condition!", 2, 0, 0,
1301 as_a_scm_t_subr (gdbscm_set_breakpoint_condition_x
),
1303 Set the breakpoint's condition.\n\
1305 Arguments: <gdb:breakpoint> condition\n\
1306 condition: a string" },
1308 { "breakpoint-stop", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_stop
),
1310 Return the breakpoint's stop predicate.\n\
1311 Return #f if there isn't one." },
1313 { "set-breakpoint-stop!", 2, 0, 0,
1314 as_a_scm_t_subr (gdbscm_set_breakpoint_stop_x
),
1316 Set the breakpoint's stop predicate.\n\
1318 Arguments: <gdb:breakpoint> procedure\n\
1319 procedure: A procedure of one argument, the breakpoint.\n\
1320 Its result is true if program execution should stop." },
1322 { "breakpoint-commands", 1, 0, 0,
1323 as_a_scm_t_subr (gdbscm_breakpoint_commands
),
1325 Return the breakpoint's commands." },
1331 gdbscm_initialize_breakpoints (void)
1334 = gdbscm_make_smob_type (breakpoint_smob_name
, sizeof (breakpoint_smob
));
1335 scm_set_smob_free (breakpoint_smob_tag
, bpscm_free_breakpoint_smob
);
1336 scm_set_smob_print (breakpoint_smob_tag
, bpscm_print_breakpoint_smob
);
1338 observer_attach_breakpoint_created (bpscm_breakpoint_created
);
1339 observer_attach_breakpoint_deleted (bpscm_breakpoint_deleted
);
1341 gdbscm_define_integer_constants (breakpoint_integer_constants
, 1);
1342 gdbscm_define_functions (breakpoint_functions
, 1);
1344 type_keyword
= scm_from_latin1_keyword ("type");
1345 wp_class_keyword
= scm_from_latin1_keyword ("wp-class");
1346 internal_keyword
= scm_from_latin1_keyword ("internal");