diff options
Diffstat (limited to 'gdb/guile/scm-breakpoint.c')
| -rw-r--r-- | gdb/guile/scm-breakpoint.c | 1200 |
1 files changed, 1200 insertions, 0 deletions
diff --git a/gdb/guile/scm-breakpoint.c b/gdb/guile/scm-breakpoint.c new file mode 100644 index 0000000..d022377 --- /dev/null +++ b/gdb/guile/scm-breakpoint.c @@ -0,0 +1,1200 @@ +/* Scheme interface to breakpoints. + + Copyright (C) 2008-2014 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <http://www.gnu.org/licenses/>. */ + +/* See README file in this directory for implementation notes, coding + conventions, et.al. */ + +#include "defs.h" +#include "value.h" +#include "exceptions.h" +#include "breakpoint.h" +#include "gdbcmd.h" +#include "gdbthread.h" +#include "observer.h" +#include "cli/cli-script.h" +#include "ada-lang.h" +#include "arch-utils.h" +#include "language.h" +#include "guile-internal.h" + +/* The <gdb:breakpoint> smob. + N.B.: The name of this struct is known to breakpoint.h. */ + +typedef struct gdbscm_breakpoint_object +{ + /* This always appears first. */ + gdb_smob base; + + /* The breakpoint number according to gdb. + This is recorded here because BP will be NULL when deleted. */ + int number; + + /* The gdb breakpoint object, or NULL if the breakpoint has been deleted. */ + struct breakpoint *bp; + + /* Backlink to our containing <gdb:breakpoint> smob. + This is needed when we are deleted, we need to unprotect the object + from GC. */ + SCM containing_scm; + + /* A stop condition or #f. */ + SCM stop; +} breakpoint_smob; + +static const char breakpoint_smob_name[] = "gdb:breakpoint"; + +/* The tag Guile knows the breakpoint smob by. */ +static scm_t_bits breakpoint_smob_tag; + +/* Variables used to pass information between the breakpoint_smob + constructor and the breakpoint-created hook function. */ +static SCM pending_breakpoint_scm = SCM_BOOL_F; + +/* Keywords used by create-breakpoint!. */ +static SCM type_keyword; +static SCM wp_class_keyword; +static SCM internal_keyword; + +/* Administrivia for breakpoint smobs. */ + +/* The smob "mark" function for <gdb:breakpoint>. */ + +static SCM +bpscm_mark_breakpoint_smob (SCM self) +{ + breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self); + + /* We don't mark containing_scm here. It is just a backlink to our + container, and is gc'protected until the breakpoint is deleted. */ + + scm_gc_mark (bp_smob->stop); + + /* Do this last. */ + return gdbscm_mark_gsmob (&bp_smob->base); +} + +/* The smob "free" function for <gdb:breakpoint>. */ + +static size_t +bpscm_free_breakpoint_smob (SCM self) +{ + breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self); + + if (bp_smob->bp) + bp_smob->bp->scm_bp_object = NULL; + + /* Not necessary, done to catch bugs. */ + bp_smob->bp = NULL; + bp_smob->containing_scm = SCM_UNDEFINED; + bp_smob->stop = SCM_UNDEFINED; + + return 0; +} + +/* Return the name of TYPE. + This doesn't handle all types, just the ones we export. */ + +static const char * +bpscm_type_to_string (enum bptype type) +{ + switch (type) + { + case bp_none: return "BP_NONE"; + case bp_breakpoint: return "BP_BREAKPOINT"; + case bp_watchpoint: return "BP_WATCHPOINT"; + case bp_hardware_watchpoint: return "BP_HARDWARE_WATCHPOINT"; + case bp_read_watchpoint: return "BP_READ_WATCHPOINT"; + case bp_access_watchpoint: return "BP_ACCESS_WATCHPOINT"; + default: return "internal/other"; + } +} + +/* Return the name of ENABLE_STATE. */ + +static const char * +bpscm_enable_state_to_string (enum enable_state enable_state) +{ + switch (enable_state) + { + case bp_disabled: return "disabled"; + case bp_enabled: return "enabled"; + case bp_call_disabled: return "call_disabled"; + case bp_permanent: return "permanent"; + default: return "unknown"; + } +} + +/* The smob "print" function for <gdb:breakpoint>. */ + +static int +bpscm_print_breakpoint_smob (SCM self, SCM port, scm_print_state *pstate) +{ + breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self); + struct breakpoint *b = bp_smob->bp; + + gdbscm_printf (port, "#<%s", breakpoint_smob_name); + + /* Only print what we export to the user. + The rest are possibly internal implementation details. */ + + gdbscm_printf (port, " #%d", bp_smob->number); + + /* Careful, the breakpoint may be invalid. */ + if (b != NULL) + { + gdbscm_printf (port, " %s %s %s", + bpscm_type_to_string (b->type), + bpscm_enable_state_to_string (b->enable_state), + b->silent ? "silent" : "noisy"); + + gdbscm_printf (port, " hit:%d", b->hit_count); + gdbscm_printf (port, " ignore:%d", b->ignore_count); + + if (b->addr_string != NULL) + gdbscm_printf (port, " @%s", b->addr_string); + } + + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +/* Low level routine to create a <gdb:breakpoint> object. */ + +static SCM +bpscm_make_breakpoint_smob (void) +{ + breakpoint_smob *bp_smob = (breakpoint_smob *) + scm_gc_malloc (sizeof (breakpoint_smob), breakpoint_smob_name); + SCM bp_scm; + + bp_smob->number = -1; + bp_smob->bp = NULL; + bp_smob->stop = SCM_BOOL_F; + bp_scm = scm_new_smob (breakpoint_smob_tag, (scm_t_bits) bp_smob); + bp_smob->containing_scm = bp_scm; + gdbscm_init_gsmob (&bp_smob->base); + + return bp_scm; +} + +/* Return non-zero if we want a Scheme wrapper for breakpoint B. + If FROM_SCHEME is non-zero,this is called for a breakpoint created + by the user from Scheme. Otherwise it is zero. */ + +static int +bpscm_want_scm_wrapper_p (struct breakpoint *bp, int from_scheme) +{ + /* Don't create <gdb:breakpoint> objects for internal GDB breakpoints. */ + if (bp->number < 0 && !from_scheme) + return 0; + + /* The others are not supported. */ + if (bp->type != bp_breakpoint + && bp->type != bp_watchpoint + && bp->type != bp_hardware_watchpoint + && bp->type != bp_read_watchpoint + && bp->type != bp_access_watchpoint) + return 0; + + return 1; +} + +/* Install the Scheme side of a breakpoint, CONTAINING_SCM, in + the gdb side BP. */ + +static void +bpscm_attach_scm_to_breakpoint (struct breakpoint *bp, SCM containing_scm) +{ + breakpoint_smob *bp_smob; + + bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (containing_scm); + bp_smob->number = bp->number; + bp_smob->bp = bp; + bp_smob->containing_scm = containing_scm; + bp_smob->bp->scm_bp_object = bp_smob; + + /* The owner of this breakpoint is not in GC-controlled memory, so we need + to protect it from GC until the breakpoint is deleted. */ + scm_gc_protect_object (containing_scm); +} + +/* Return non-zero if SCM is a breakpoint smob. */ + +static int +bpscm_is_breakpoint (SCM scm) +{ + return SCM_SMOB_PREDICATE (breakpoint_smob_tag, scm); +} + +/* (breakpoint? scm) -> boolean */ + +static SCM +gdbscm_breakpoint_p (SCM scm) +{ + return scm_from_bool (bpscm_is_breakpoint (scm)); +} + +/* Returns the <gdb:breakpoint> object in SELF. + Throws an exception if SELF is not a <gdb:breakpoint> object. */ + +static SCM +bpscm_get_breakpoint_arg_unsafe (SCM self, int arg_pos, const char *func_name) +{ + SCM_ASSERT_TYPE (bpscm_is_breakpoint (self), self, arg_pos, func_name, + breakpoint_smob_name); + + return self; +} + +/* Returns a pointer to the breakpoint smob of SELF. + Throws an exception if SELF is not a <gdb:breakpoint> object. */ + +static breakpoint_smob * +bpscm_get_breakpoint_smob_arg_unsafe (SCM self, int arg_pos, + const char *func_name) +{ + SCM bp_scm = bpscm_get_breakpoint_arg_unsafe (self, arg_pos, func_name); + breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (bp_scm); + + return bp_smob; +} + +/* Return non-zero if breakpoint BP_SMOB is valid. */ + +static int +bpscm_is_valid (breakpoint_smob *bp_smob) +{ + return bp_smob->bp != NULL; +} + +/* Returns the breakpoint smob in SELF, verifying it's valid. + Throws an exception if SELF is not a <gdb:breakpoint> object, + or is invalid. */ + +static breakpoint_smob * +bpscm_get_valid_breakpoint_smob_arg_unsafe (SCM self, int arg_pos, + const char *func_name) +{ + breakpoint_smob *bp_smob + = bpscm_get_breakpoint_smob_arg_unsafe (self, arg_pos, func_name); + + if (!bpscm_is_valid (bp_smob)) + { + gdbscm_invalid_object_error (func_name, arg_pos, self, + _("<gdb:breakpoint>")); + } + + return bp_smob; +} + +/* Breakpoint methods. */ + +/* (create-breakpoint! string [#:type integer] [#:wp-class integer] + [#:internal boolean) -> <gdb:breakpoint> */ + +static SCM +gdbscm_create_breakpoint_x (SCM spec_scm, SCM rest) +{ + const SCM keywords[] = { + type_keyword, wp_class_keyword, internal_keyword, SCM_BOOL_F + }; + char *spec; + int type_arg_pos = -1, access_type_arg_pos = -1, internal_arg_pos = -1; + int type = bp_breakpoint; + int access_type = hw_write; + int internal = 0; + SCM result; + volatile struct gdb_exception except; + + gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iit", + spec_scm, &spec, rest, + &type_arg_pos, &type, + &access_type_arg_pos, &access_type, + &internal_arg_pos, &internal); + + result = bpscm_make_breakpoint_smob (); + pending_breakpoint_scm = result; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + struct cleanup *cleanup = make_cleanup (xfree, spec); + + switch (type) + { + case bp_breakpoint: + { + create_breakpoint (get_current_arch (), + spec, NULL, -1, NULL, + 0, + 0, bp_breakpoint, + 0, + AUTO_BOOLEAN_TRUE, + &bkpt_breakpoint_ops, + 0, 1, internal, 0); + break; + } + case bp_watchpoint: + { + if (access_type == hw_write) + watch_command_wrapper (spec, 0, internal); + else if (access_type == hw_access) + awatch_command_wrapper (spec, 0, internal); + else if (access_type == hw_read) + rwatch_command_wrapper (spec, 0, internal); + else + error (_("Invalid watchpoint access type")); + break; + } + default: + error (_("Invalid breakpoint type")); + } + + do_cleanups (cleanup); + } + /* Ensure this gets reset, even if there's an error. */ + pending_breakpoint_scm = SCM_BOOL_F; + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return result; +} + +/* (breakpoint-delete! <gdb:breakpoint>) -> unspecified + Scheme function which deletes the underlying GDB breakpoint. This + triggers the breakpoint_deleted observer which will call + gdbscm_breakpoint_deleted; that function cleans up the Scheme sections. */ + +static SCM +gdbscm_breakpoint_delete_x (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + volatile struct gdb_exception except; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + delete_breakpoint (bp_smob->bp); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* iterate_over_breakpoints function for gdbscm_breakpoints. */ + +static int +bpscm_build_bp_list (struct breakpoint *bp, void *arg) +{ + SCM *list = arg; + breakpoint_smob *bp_smob = bp->scm_bp_object; + + /* Lazily create wrappers for breakpoints created outside Scheme. */ + + if (bp_smob == NULL) + { + if (bpscm_want_scm_wrapper_p (bp, 0)) + { + SCM bp_scm; + + bp_scm = bpscm_make_breakpoint_smob (); + bpscm_attach_scm_to_breakpoint (bp, bp_scm); + /* Refetch it. */ + bp_smob = bp->scm_bp_object; + } + } + + /* Not all breakpoints will have a companion Scheme object. + Only breakpoints that trigger the created_breakpoint observer call, + and satisfy certain conditions (see bpscm_want_scm_wrapper_p), + get a companion object (this includes Scheme-created breakpoints). */ + + if (bp_smob != NULL) + *list = scm_cons (bp_smob->containing_scm, *list); + + return 0; +} + +/* (breakpoints) -> list + Return a list of all breakpoints. */ + +static SCM +gdbscm_breakpoints (void) +{ + SCM list = SCM_EOL; + + /* If iterate_over_breakpoints returns non-NULL it means the iteration + terminated early. + In that case abandon building the list and return #f. */ + if (iterate_over_breakpoints (bpscm_build_bp_list, &list) != NULL) + return SCM_BOOL_F; + + return scm_reverse_x (list, SCM_EOL); +} + +/* (breakpoint-valid? <gdb:breakpoint>) -> boolean + Returns #t if SELF is still valid. */ + +static SCM +gdbscm_breakpoint_valid_p (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_bool (bpscm_is_valid (bp_smob)); +} + +/* (breakpoint-enabled? <gdb:breakpoint>) -> boolean */ + +static SCM +gdbscm_breakpoint_enabled_p (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_bool (bp_smob->bp->enable_state == bp_enabled); +} + +/* (set-breakpoint-enabled? <gdb:breakpoint> boolean) -> unspecified */ + +static SCM +gdbscm_set_breakpoint_enabled_x (SCM self, SCM newvalue) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + volatile struct gdb_exception except; + + SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME, + _("boolean")); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + if (gdbscm_is_true (newvalue)) + enable_breakpoint (bp_smob->bp); + else + disable_breakpoint (bp_smob->bp); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* (breakpoint-silent? <gdb:breakpoint>) -> boolean */ + +static SCM +gdbscm_breakpoint_silent_p (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_bool (bp_smob->bp->silent); +} + +/* (set-breakpoint-silent?! <gdb:breakpoint> boolean) -> unspecified */ + +static SCM +gdbscm_set_breakpoint_silent_x (SCM self, SCM newvalue) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + volatile struct gdb_exception except; + + SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME, + _("boolean")); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + breakpoint_set_silent (bp_smob->bp, gdbscm_is_true (newvalue)); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* (breakpoint-ignore-count <gdb:breakpoint>) -> integer */ + +static SCM +gdbscm_breakpoint_ignore_count (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_long (bp_smob->bp->ignore_count); +} + +/* (set-breakpoint-ignore-count! <gdb:breakpoint> integer) + -> unspecified */ + +static SCM +gdbscm_set_breakpoint_ignore_count_x (SCM self, SCM newvalue) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + long value; + volatile struct gdb_exception except; + + SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX), + newvalue, SCM_ARG2, FUNC_NAME, _("integer")); + + value = scm_to_long (newvalue); + if (value < 0) + value = 0; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + set_ignore_count (bp_smob->number, (int) value, 0); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* (breakpoint-hit-count <gdb:breakpoint>) -> integer */ + +static SCM +gdbscm_breakpoint_hit_count (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_long (bp_smob->bp->hit_count); +} + +/* (set-breakpoint-hit-count! <gdb:breakpoint> integer) -> unspecified */ + +static SCM +gdbscm_set_breakpoint_hit_count_x (SCM self, SCM newvalue) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + long value; + + SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX), + newvalue, SCM_ARG2, FUNC_NAME, _("integer")); + + value = scm_to_long (newvalue); + if (value < 0) + value = 0; + + if (value != 0) + { + gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue, + _("hit-count must be zero")); + } + + bp_smob->bp->hit_count = 0; + + return SCM_UNSPECIFIED; +} + +/* (breakpoint-thread <gdb:breakpoint>) -> integer */ + +static SCM +gdbscm_breakpoint_thread (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + if (bp_smob->bp->thread == -1) + return SCM_BOOL_F; + + return scm_from_long (bp_smob->bp->thread); +} + +/* (set-breakpoint-thread! <gdb:breakpoint> integer) -> unspecified */ + +static SCM +gdbscm_set_breakpoint_thread_x (SCM self, SCM newvalue) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + long id; + + if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX)) + { + id = scm_to_long (newvalue); + if (! valid_thread_id (id)) + { + gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue, + _("invalid thread id")); + } + } + else if (gdbscm_is_false (newvalue)) + id = -1; + else + SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f")); + + breakpoint_set_thread (bp_smob->bp, id); + + return SCM_UNSPECIFIED; +} + +/* (breakpoint-task <gdb:breakpoint>) -> integer */ + +static SCM +gdbscm_breakpoint_task (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + if (bp_smob->bp->task == 0) + return SCM_BOOL_F; + + return scm_from_long (bp_smob->bp->task); +} + +/* (set-breakpoint-task! <gdb:breakpoint> integer) -> unspecified */ + +static SCM +gdbscm_set_breakpoint_task_x (SCM self, SCM newvalue) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + long id; + int valid_id = 0; + volatile struct gdb_exception except; + + if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX)) + { + id = scm_to_long (newvalue); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + valid_id = valid_task_id (id); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + if (! valid_id) + { + gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue, + _("invalid task id")); + } + } + else if (gdbscm_is_false (newvalue)) + id = 0; + else + SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f")); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + breakpoint_set_task (bp_smob->bp, id); + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* (breakpoint-location <gdb:breakpoint>) -> string */ + +static SCM +gdbscm_breakpoint_location (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + char *str; + + if (bp_smob->bp->type != bp_breakpoint) + return SCM_BOOL_F; + + str = bp_smob->bp->addr_string; + if (! str) + str = ""; + + return gdbscm_scm_from_c_string (str); +} + +/* (breakpoint-expression <gdb:breakpoint>) -> string + This is only valid for watchpoints. + Returns #f for non-watchpoints. */ + +static SCM +gdbscm_breakpoint_expression (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + char *str; + struct watchpoint *wp; + + if (!is_watchpoint (bp_smob->bp)) + return SCM_BOOL_F; + + wp = (struct watchpoint *) bp_smob->bp; + + str = wp->exp_string; + if (! str) + str = ""; + + return gdbscm_scm_from_c_string (str); +} + +/* (breakpoint-condition <gdb:breakpoint>) -> string */ + +static SCM +gdbscm_breakpoint_condition (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + char *str; + + str = bp_smob->bp->cond_string; + if (! str) + return SCM_BOOL_F; + + return gdbscm_scm_from_c_string (str); +} + +/* (set-breakpoint-condition! <gdb:breakpoint> string|#f) + -> unspecified */ + +static SCM +gdbscm_set_breakpoint_condition_x (SCM self, SCM newvalue) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + char *exp; + volatile struct gdb_exception except; + + SCM_ASSERT_TYPE (scm_is_string (newvalue) || gdbscm_is_false (newvalue), + newvalue, SCM_ARG2, FUNC_NAME, + _("string or #f")); + + if (gdbscm_is_false (newvalue)) + exp = NULL; + else + exp = gdbscm_scm_to_c_string (newvalue); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + set_breakpoint_condition (bp_smob->bp, exp ? exp : "", 0); + } + xfree (exp); + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* (breakpoint-stop <gdb:breakpoint>) -> procedure or #f */ + +static SCM +gdbscm_breakpoint_stop (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return bp_smob->stop; +} + +/* (set-breakpoint-stop! <gdb:breakpoint> procedure|#f) + -> unspecified */ + +static SCM +gdbscm_set_breakpoint_stop_x (SCM self, SCM newvalue) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + const struct extension_language_defn *extlang = NULL; + + SCM_ASSERT_TYPE (gdbscm_is_procedure (newvalue) + || gdbscm_is_false (newvalue), + newvalue, SCM_ARG2, FUNC_NAME, + _("procedure or #f")); + + if (bp_smob->bp->cond_string != NULL) + extlang = get_ext_lang_defn (EXT_LANG_GDB); + if (extlang == NULL) + extlang = get_breakpoint_cond_ext_lang (bp_smob->bp, EXT_LANG_GUILE); + if (extlang != NULL) + { + char *error_text + = xstrprintf (_("Only one stop condition allowed. There is" + " currently a %s stop condition defined for" + " this breakpoint."), + ext_lang_capitalized_name (extlang)); + + scm_dynwind_begin (0); + gdbscm_dynwind_xfree (error_text); + gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self, error_text); + /* The following line, while unnecessary, is present for completeness + sake. */ + scm_dynwind_end (); + } + + bp_smob->stop = newvalue; + + return SCM_UNSPECIFIED; +} + +/* (breakpoint-commands <gdb:breakpoint>) -> string */ + +static SCM +gdbscm_breakpoint_commands (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + struct breakpoint *bp; + long length; + volatile struct gdb_exception except; + struct ui_file *string_file; + struct cleanup *chain; + SCM result; + char *cmdstr; + + bp = bp_smob->bp; + + if (bp->commands == NULL) + return SCM_BOOL_F; + + string_file = mem_fileopen (); + chain = make_cleanup_ui_file_delete (string_file); + + ui_out_redirect (current_uiout, string_file); + TRY_CATCH (except, RETURN_MASK_ALL) + { + print_command_lines (current_uiout, breakpoint_commands (bp), 0); + } + ui_out_redirect (current_uiout, NULL); + if (except.reason < 0) + { + do_cleanups (chain); + gdbscm_throw_gdb_exception (except); + } + + cmdstr = ui_file_xstrdup (string_file, &length); + make_cleanup (xfree, cmdstr); + result = gdbscm_scm_from_c_string (cmdstr); + + do_cleanups (chain); + return result; +} + +/* (breakpoint-type <gdb:breakpoint>) -> integer */ + +static SCM +gdbscm_breakpoint_type (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_long (bp_smob->bp->type); +} + +/* (breakpoint-visible? <gdb:breakpoint>) -> boolean */ + +static SCM +gdbscm_breakpoint_visible (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_bool (bp_smob->bp->number >= 0); +} + +/* (breakpoint-number <gdb:breakpoint>) -> integer */ + +static SCM +gdbscm_breakpoint_number (SCM self) +{ + breakpoint_smob *bp_smob + = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + + return scm_from_long (bp_smob->number); +} + +/* Return TRUE if "stop" has been set for this breakpoint. + + This is the extension_language_ops.breakpoint_has_cond "method". */ + +int +gdbscm_breakpoint_has_cond (const struct extension_language_defn *extlang, + struct breakpoint *b) +{ + breakpoint_smob *bp_smob = b->scm_bp_object; + + if (bp_smob == NULL) + return 0; + + return gdbscm_is_procedure (bp_smob->stop); +} + +/* Call the "stop" method in the breakpoint class. + This must only be called if gdbscm_breakpoint_has_cond returns true. + If the stop method returns #t, the inferior will be stopped at the + breakpoint. Otherwise the inferior will be allowed to continue + (assuming other conditions don't indicate "stop"). + + This is the extension_language_ops.breakpoint_cond_says_stop "method". */ + +enum ext_lang_bp_stop +gdbscm_breakpoint_cond_says_stop + (const struct extension_language_defn *extlang, struct breakpoint *b) +{ + breakpoint_smob *bp_smob = b->scm_bp_object; + SCM predicate_result; + int stop; + + if (bp_smob == NULL) + return EXT_LANG_BP_STOP_UNSET; + if (!gdbscm_is_procedure (bp_smob->stop)) + return EXT_LANG_BP_STOP_UNSET; + + stop = 1; + + predicate_result + = gdbscm_safe_call_1 (bp_smob->stop, bp_smob->containing_scm, NULL); + + if (gdbscm_is_exception (predicate_result)) + ; /* Exception already printed. */ + /* If the "stop" function returns #f that means + the Scheme breakpoint wants GDB to continue. */ + else if (gdbscm_is_false (predicate_result)) + stop = 0; + + return stop ? EXT_LANG_BP_STOP_YES : EXT_LANG_BP_STOP_NO; +} + +/* Event callback functions. */ + +/* Callback that is used when a breakpoint is created. + For breakpoints created by Scheme, i.e., gdbscm_create_breakpoint_x, finish + object creation by connecting the Scheme wrapper to the gdb object. + We ignore breakpoints created from gdb or python here, we create the + Scheme wrapper for those when there's a need to, e.g., + gdbscm_breakpoints. */ + +static void +bpscm_breakpoint_created (struct breakpoint *bp) +{ + SCM bp_scm; + + if (gdbscm_is_false (pending_breakpoint_scm)) + return; + + /* Verify our caller error checked the user's request. */ + gdb_assert (bpscm_want_scm_wrapper_p (bp, 1)); + + bp_scm = pending_breakpoint_scm; + pending_breakpoint_scm = SCM_BOOL_F; + + bpscm_attach_scm_to_breakpoint (bp, bp_scm); +} + +/* Callback that is used when a breakpoint is deleted. This will + invalidate the corresponding Scheme object. */ + +static void +bpscm_breakpoint_deleted (struct breakpoint *b) +{ + int num = b->number; + struct breakpoint *bp; + + /* TODO: Why the lookup? We have B. */ + + bp = get_breakpoint (num); + if (bp) + { + breakpoint_smob *bp_smob = bp->scm_bp_object; + + if (bp_smob) + { + bp_smob->bp = NULL; + scm_gc_unprotect_object (bp_smob->containing_scm); + } + } +} + +/* Initialize the Scheme breakpoint code. */ + +static const scheme_integer_constant breakpoint_integer_constants[] = +{ + { "BP_NONE", bp_none }, + { "BP_BREAKPOINT", bp_breakpoint }, + { "BP_WATCHPOINT", bp_watchpoint }, + { "BP_HARDWARE_WATCHPOINT", bp_hardware_watchpoint }, + { "BP_READ_WATCHPOINT", bp_read_watchpoint }, + { "BP_ACCESS_WATCHPOINT", bp_access_watchpoint }, + + { "WP_READ", hw_read }, + { "WP_WRITE", hw_write }, + { "WP_ACCESS", hw_access }, + + END_INTEGER_CONSTANTS +}; + +static const scheme_function breakpoint_functions[] = +{ + { "create-breakpoint!", 1, 0, 1, gdbscm_create_breakpoint_x, + "\ +Create and install a GDB breakpoint object.\n\ +\n\ + Arguments:\n\ + location [#:type <type>] [#:wp-class <wp-class>] [#:internal <bool>]" }, + + { "breakpoint-delete!", 1, 0, 0, gdbscm_breakpoint_delete_x, + "\ +Delete the breakpoint from GDB." }, + + { "breakpoints", 0, 0, 0, gdbscm_breakpoints, + "\ +Return a list of all GDB breakpoints.\n\ +\n\ + Arguments: none" }, + + { "breakpoint?", 1, 0, 0, gdbscm_breakpoint_p, + "\ +Return #t if the object is a <gdb:breakpoint> object." }, + + { "breakpoint-valid?", 1, 0, 0, gdbscm_breakpoint_valid_p, + "\ +Return #t if the breakpoint has not been deleted from GDB." }, + + { "breakpoint-number", 1, 0, 0, gdbscm_breakpoint_number, + "\ +Return the breakpoint's number." }, + + { "breakpoint-type", 1, 0, 0, gdbscm_breakpoint_type, + "\ +Return the type of the breakpoint." }, + + { "breakpoint-visible?", 1, 0, 0, gdbscm_breakpoint_visible, + "\ +Return #t if the breakpoint is visible to the user." }, + + { "breakpoint-location", 1, 0, 0, gdbscm_breakpoint_location, + "\ +Return the location of the breakpoint as specified by the user." }, + + { "breakpoint-expression", 1, 0, 0, gdbscm_breakpoint_expression, + "\ +Return the expression of the breakpoint as specified by the user.\n\ +Valid for watchpoints only, returns #f for non-watchpoints." }, + + { "breakpoint-enabled?", 1, 0, 0, gdbscm_breakpoint_enabled_p, + "\ +Return #t if the breakpoint is enabled." }, + + { "set-breakpoint-enabled!", 2, 0, 0, gdbscm_set_breakpoint_enabled_x, + "\ +Set the breakpoint's enabled state.\n\ +\n\ + Arguments: <gdb:breakpoint boolean" }, + + { "breakpoint-silent?", 1, 0, 0, gdbscm_breakpoint_silent_p, + "\ +Return #t if the breakpoint is silent." }, + + { "set-breakpoint-silent!", 2, 0, 0, gdbscm_set_breakpoint_silent_x, + "\ +Set the breakpoint's silent state.\n\ +\n\ + Arguments: <gdb:breakpoint> boolean" }, + + { "breakpoint-ignore-count", 1, 0, 0, gdbscm_breakpoint_ignore_count, + "\ +Return the breakpoint's \"ignore\" count." }, + + { "set-breakpoint-ignore-count!", 2, 0, 0, + gdbscm_set_breakpoint_ignore_count_x, + "\ +Set the breakpoint's \"ignore\" count.\n\ +\n\ + Arguments: <gdb:breakpoint> count" }, + + { "breakpoint-hit-count", 1, 0, 0, gdbscm_breakpoint_hit_count, + "\ +Return the breakpoint's \"hit\" count." }, + + { "set-breakpoint-hit-count!", 2, 0, 0, gdbscm_set_breakpoint_hit_count_x, + "\ +Set the breakpoint's \"hit\" count. The value must be zero.\n\ +\n\ + Arguments: <gdb:breakpoint> 0" }, + + { "breakpoint-thread", 1, 0, 0, gdbscm_breakpoint_thread, + "\ +Return the breakpoint's thread id or #f if there isn't one." }, + + { "set-breakpoint-thread!", 2, 0, 0, gdbscm_set_breakpoint_thread_x, + "\ +Set the thread id for this breakpoint.\n\ +\n\ + Arguments: <gdb:breakpoint> thread-id" }, + + { "breakpoint-task", 1, 0, 0, gdbscm_breakpoint_task, + "\ +Return the breakpoint's Ada task-id or #f if there isn't one." }, + + { "set-breakpoint-task!", 2, 0, 0, gdbscm_set_breakpoint_task_x, + "\ +Set the breakpoint's Ada task-id.\n\ +\n\ + Arguments: <gdb:breakpoint> task-id" }, + + { "breakpoint-condition", 1, 0, 0, gdbscm_breakpoint_condition, + "\ +Return the breakpoint's condition as specified by the user.\n\ +Return #f if there isn't one." }, + + { "set-breakpoint-condition!", 2, 0, 0, gdbscm_set_breakpoint_condition_x, + "\ +Set the breakpoint's condition.\n\ +\n\ + Arguments: <gdb:breakpoint> condition\n\ + condition: a string" }, + + { "breakpoint-stop", 1, 0, 0, gdbscm_breakpoint_stop, + "\ +Return the breakpoint's stop predicate.\n\ +Return #f if there isn't one." }, + + { "set-breakpoint-stop!", 2, 0, 0, gdbscm_set_breakpoint_stop_x, + "\ +Set the breakpoint's stop predicate.\n\ +\n\ + Arguments: <gdb:breakpoint> procedure\n\ + procedure: A procedure of one argument, the breakpoint.\n\ + Its result is true if program execution should stop." }, + + { "breakpoint-commands", 1, 0, 0, gdbscm_breakpoint_commands, + "\ +Return the breakpoint's commands." }, + + END_FUNCTIONS +}; + +void +gdbscm_initialize_breakpoints (void) +{ + breakpoint_smob_tag + = gdbscm_make_smob_type (breakpoint_smob_name, sizeof (breakpoint_smob)); + scm_set_smob_mark (breakpoint_smob_tag, bpscm_mark_breakpoint_smob); + scm_set_smob_free (breakpoint_smob_tag, bpscm_free_breakpoint_smob); + scm_set_smob_print (breakpoint_smob_tag, bpscm_print_breakpoint_smob); + + observer_attach_breakpoint_created (bpscm_breakpoint_created); + observer_attach_breakpoint_deleted (bpscm_breakpoint_deleted); + + gdbscm_define_integer_constants (breakpoint_integer_constants, 1); + gdbscm_define_functions (breakpoint_functions, 1); + + type_keyword = scm_from_latin1_keyword ("type"); + wp_class_keyword = scm_from_latin1_keyword ("wp-class"); + internal_keyword = scm_from_latin1_keyword ("internal"); +} |