This is the mail archive of the
gdb-patches@sourceware.org
mailing list for the GDB project.
[PATCH v2 20/36] Guile extension language: scm-breakpoint.c
- From: Doug Evans <xdje42 at gmail dot com>
- To: gdb-patches at sourceware dot org
- Date: Mon, 20 Jan 2014 13:53:14 -0800
- Subject: [PATCH v2 20/36] Guile extension language: scm-breakpoint.c
- Authentication-results: sourceware.org; auth=none
This patch adds the interface to breakpoints.
Changes from v1:
- rename make-breakpoint to create-breakpoint!
- in my mind make-foo routines should avoid side-effects,
and since this installs a breakpoint in gdb it doesn't feel
like a make-foo routine
2014-01-20 Doug Evans <xdje42@gmail.com>
* guile/scm-breakpoint.c: New file.
testsuite/
* gdb.guile/scm-breakpoint.c: New file.
* gdb.guile/scm-breakpoint.exp: New file.
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");
+}
diff --git a/gdb/testsuite/gdb.guile/scm-breakpoint.c b/gdb/testsuite/gdb.guile/scm-breakpoint.c
new file mode 100644
index 0000000..c8dc7f7
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-breakpoint.c
@@ -0,0 +1,44 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2014 Free Software Foundation, Inc.
+
+ 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/>. */
+
+int result = 0;
+
+int multiply (int i)
+{
+ return i * i;
+}
+
+int add (int i)
+{
+ return i + i;
+}
+
+
+int main (int argc, char *argv[])
+{
+ int foo = 5;
+ int bar = 42;
+ int i;
+
+ for (i = 0; i < 10; i++)
+ {
+ result += multiply (foo); /* Break at multiply. */
+ result += add (bar); /* Break at add. */
+ }
+
+ return 0; /* Break at end. */
+}
diff --git a/gdb/testsuite/gdb.guile/scm-breakpoint.exp b/gdb/testsuite/gdb.guile/scm-breakpoint.exp
new file mode 100644
index 0000000..b25d4e0
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-breakpoint.exp
@@ -0,0 +1,438 @@
+# Copyright (C) 2010-2014 Free Software Foundation, Inc.
+#
+# 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/>.
+
+# This file is part of the GDB testsuite.
+# It tests the mechanism exposing breakpoints to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+ return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+proc test_bkpt_basic { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix "test_bkpt_basic" {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ # Initially there should be one breakpoint: main.
+
+ gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
+ "get breakpoint list 1"
+ gdb_test "guile (print (car blist))" \
+ "<gdb:breakpoint #1 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @main>" \
+ "check main breakpoint"
+ gdb_test "guile (print (breakpoint-location (car blist)))" \
+ "main" "check main breakpoint location"
+
+ set mult_line [gdb_get_line_number "Break at multiply."]
+ gdb_breakpoint ${mult_line}
+ gdb_continue_to_breakpoint "Break at multiply."
+
+ # Check that the Guile breakpoint code noted the addition of a
+ # breakpoint "behind the scenes".
+ gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
+ "get breakpoint list 2"
+ gdb_scm_test_silent_cmd "guile (define mult-bkpt (cadr blist))" \
+ "get multiply breakpoint"
+ gdb_test "guile (print (length blist))" \
+ "= 2" "check for two breakpoints"
+ gdb_test "guile (print mult-bkpt)" \
+ "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @.*scm-breakpoint.c:$mult_line>" \
+ "check multiply breakpoint"
+ gdb_test "guile (print (breakpoint-location mult-bkpt))" \
+ "scm-breakpoint\.c:${mult_line}*" \
+ "check multiply breakpoint location"
+
+ # Check hit and ignore counts.
+ gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \
+ "= 1" "check multiply breakpoint hit count"
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-ignore-count! mult-bkpt 4)" \
+ "set multiply breakpoint ignore count"
+ gdb_continue_to_breakpoint "Break at multiply."
+ gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \
+ "= 6" "check multiply breakpoint hit count 2"
+ gdb_test "print result" \
+ " = 545" "check expected variable result after 6 iterations"
+
+ # Test breakpoint is enabled and disabled correctly.
+ gdb_breakpoint [gdb_get_line_number "Break at add."]
+ gdb_continue_to_breakpoint "Break at add."
+ gdb_test "guile (print (breakpoint-enabled? mult-bkpt))" \
+ "= #t" "check multiply breakpoint enabled"
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #f)" \
+ "set multiply breakpoint disabled"
+ gdb_continue_to_breakpoint "Break at add."
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #t)" \
+ "set multiply breakpoint enabled"
+ gdb_continue_to_breakpoint "Break at multiply."
+
+ # Test other getters and setters.
+ gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
+ "get breakpoint list 3"
+ gdb_test "guile (print (breakpoint-thread mult-bkpt))" \
+ "= #f" "check breakpoint thread"
+ gdb_test "guile (print (= (breakpoint-type mult-bkpt) BP_BREAKPOINT))" \
+ "= #t" "check breakpoint type"
+ gdb_test "guile (print (map breakpoint-number blist))" \
+ "= \\(1 2 3\\)" "check breakpoint numbers"
+ }
+}
+
+proc test_bkpt_deletion { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_deletion {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ # Test breakpoints are deleted correctly.
+ set deltst_location [gdb_get_line_number "Break at multiply."]
+ set end_location [gdb_get_line_number "Break at end."]
+ gdb_scm_test_silent_cmd "guile (define dp1 (create-breakpoint! \"$deltst_location\"))" \
+ "create deltst breakpoint"
+ gdb_breakpoint [gdb_get_line_number "Break at end."]
+ gdb_scm_test_silent_cmd "guile (define del-list (breakpoints))" \
+ "get breakpoint list 4"
+ gdb_test "guile (print (length del-list))" \
+ "= 3" "number of breakpoints before delete"
+ gdb_continue_to_breakpoint "Break at multiply." \
+ ".*/$srcfile:$deltst_location.*"
+ gdb_scm_test_silent_cmd "guile (breakpoint-delete! dp1)" \
+ "delete breakpoint"
+ gdb_test "guile (print (breakpoint-number dp1))" \
+ "ERROR: .*: Invalid object: <gdb:breakpoint> in position 1: #<gdb:breakpoint #2>.*" \
+ "check breakpoint invalidated"
+ gdb_scm_test_silent_cmd "guile (set! del-list (breakpoints))" \
+ "get breakpoint list 5"
+ gdb_test "guile (print (length del-list))" \
+ "= 2" "number of breakpoints after delete"
+ gdb_continue_to_breakpoint "Break at end." ".*/$srcfile:$end_location.*"
+ }
+}
+
+proc test_bkpt_cond_and_cmds { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_cond_and_cmds {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ # Test conditional setting.
+ set bp_location1 [gdb_get_line_number "Break at multiply."]
+ gdb_scm_test_silent_cmd "guile (define bp1 (create-breakpoint! \"$bp_location1\"))" \
+ "create multiply breakpoint"
+ gdb_continue_to_breakpoint "Break at multiply."
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 \"i == 5\")" \
+ "set condition"
+ gdb_test "guile (print (breakpoint-condition bp1))" \
+ "= i == 5" "test condition has been set"
+ gdb_continue_to_breakpoint "Break at multiply."
+ gdb_test "print i" \
+ "5" "test conditional breakpoint stopped after five iterations"
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 #f)" \
+ "clear condition"
+ gdb_test "guile (print (breakpoint-condition bp1))" \
+ "= #f" "test condition has been removed"
+ gdb_continue_to_breakpoint "Break at multiply."
+ gdb_test "print i" "6" "test breakpoint stopped after six iterations"
+
+ # Test commands.
+ gdb_breakpoint [gdb_get_line_number "Break at add."]
+ set test {commands $bpnum}
+ gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
+ set test {print "Command for breakpoint has been executed."}
+ gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
+ set test {print result}
+ gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
+ gdb_test "end"
+
+ gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
+ "get breakpoint list 6"
+ gdb_test "guile (print (breakpoint-commands (list-ref blist (- (length blist) 1))))" \
+ "print \"Command for breakpoint has been executed.\".*print result"
+ }
+}
+
+proc test_bkpt_invisible { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_invisible {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ # Test invisible breakpoints.
+ delete_breakpoints
+ set ibp_location [gdb_get_line_number "Break at multiply."]
+ gdb_scm_test_silent_cmd "guile (define vbp (create-breakpoint! \"$ibp_location\" #:internal #f))" \
+ "create visible breakpoint"
+ gdb_scm_test_silent_cmd "guile (define vbp (car (breakpoints)))" \
+ "get visible breakpoint"
+ gdb_test "guile (print vbp)" \
+ "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
+ "check visible bp obj exists"
+ gdb_test "guile (print (breakpoint-location vbp))" \
+ "scm-breakpoint\.c:$ibp_location*" "check visible breakpoint location"
+ gdb_test "guile (print (breakpoint-visible? vbp))" \
+ "= #t" "check breakpoint visibility"
+ gdb_test "info breakpoints" \
+ "scm-breakpoint\.c:$ibp_location.*" \
+ "check info breakpoints shows visible breakpoints"
+ delete_breakpoints
+ gdb_scm_test_silent_cmd "guile (define ibp (create-breakpoint! \"$ibp_location\" #:internal #t))" \
+ "create invisible breakpoint"
+ gdb_test "guile (print ibp)" \
+ "= #<gdb:breakpoint #-$decimal BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
+ "check invisible bp obj exists"
+ gdb_test "guile (print (breakpoint-location ibp))" \
+ "scm-breakpoint\.c:$ibp_location*" "check invisible breakpoint location"
+ gdb_test "guile (print (breakpoint-visible? ibp))" \
+ "= #f" "check breakpoint invisibility"
+ gdb_test "info breakpoints" \
+ "No breakpoints or watchpoints.*" \
+ "check info breakpoints does not show invisible breakpoints"
+ gdb_test "maint info breakpoints" \
+ "scm-breakpoint\.c:$ibp_location.*" \
+ "check maint info breakpoints shows invisible breakpoints"
+ }
+}
+
+proc test_watchpoints { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_watchpoints {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ # Disable hardware watchpoints if necessary.
+ if [target_info exists gdb,no_hardware_watchpoints] {
+ gdb_test_no_output "set can-use-hw-watchpoints 0" ""
+ }
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ gdb_scm_test_silent_cmd "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \
+ "create watchpoint"
+ gdb_test "continue" \
+ ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \
+ "test watchpoint write"
+ }
+}
+
+proc test_bkpt_internal { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_internal {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ # Disable hardware watchpoints if necessary.
+ if [target_info exists gdb,no_hardware_watchpoints] {
+ gdb_test_no_output "set can-use-hw-watchpoints 0" ""
+ }
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ delete_breakpoints
+
+ gdb_scm_test_silent_cmd "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE #:internal #t))" \
+ "create invisible watchpoint"
+ gdb_test "info breakpoints" \
+ "No breakpoints or watchpoints.*" \
+ "check info breakpoints does not show invisible watchpoint"
+ gdb_test "maint info breakpoints" \
+ ".*watchpoint.*result.*" \
+ "check maint info breakpoints shows invisible watchpoint"
+ gdb_test "continue" \
+ ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*" \
+ "test invisible watchpoint write"
+ }
+}
+
+proc test_bkpt_eval_funcs { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_eval_funcs {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ # Disable hardware watchpoints if necessary.
+ if [target_info exists gdb,no_hardware_watchpoints] {
+ gdb_test_no_output "set can-use-hw-watchpoints 0" ""
+ }
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ delete_breakpoints
+
+ gdb_test_multiline "data collection breakpoint 1" \
+ "guile" "" \
+ "(define (make-bp-data) (cons 0 0))" "" \
+ "(define bp-data-count car)" "" \
+ "(define set-bp-data-count! set-car!)" "" \
+ "(define bp-data-inf-i cdr)" "" \
+ "(define set-bp-data-inf-i! set-cdr!)" "" \
+ "(define (bp-eval-count bkpt) (bp-data-count (gsmob-property bkpt 'bp-data)))" "" \
+ "(define (bp-eval-inf-i bkpt) (bp-data-inf-i (gsmob-property bkpt 'bp-data)))" "" \
+ "(define (make-bp-eval location)" "" \
+ " (let ((bp (create-breakpoint! location)))" "" \
+ " (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
+ " (set-breakpoint-stop! bp" "" \
+ " (lambda (bkpt)" "" \
+ " (let ((data (gsmob-property bkpt 'bp-data))" "" \
+ " (inf-i (parse-and-eval \"i\")))" "" \
+ " (set-bp-data-count! data (+ (bp-data-count data) 1))" "" \
+ " (set-bp-data-inf-i! data inf-i)" "" \
+ " (value=? inf-i 3))))" "" \
+ " bp))" "" \
+ "end" ""
+
+ gdb_test_multiline "data collection breakpoint 2" \
+ "guile" "" \
+ "(define (make-bp-also-eval location)" "" \
+ " (let ((bp (create-breakpoint! location)))" "" \
+ " (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
+ " (set-breakpoint-stop! bp" "" \
+ " (lambda (bkpt)" "" \
+ " (let* ((data (gsmob-property bkpt 'bp-data))" "" \
+ " (count (+ (bp-data-count data) 1)))" "" \
+ " (set-bp-data-count! data count)" "" \
+ " (= count 9))))" "" \
+ " bp))" "" \
+ "end" ""
+
+ gdb_test_multiline "data collection breakpoint 3" \
+ "guile" "" \
+ "(define (make-bp-basic location)" "" \
+ " (let ((bp (create-breakpoint! location)))" "" \
+ " (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
+ " bp))" "" \
+ "end" ""
+
+ set bp_location2 [gdb_get_line_number "Break at multiply."]
+ set end_location [gdb_get_line_number "Break at end."]
+ gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$bp_location2\"))" \
+ "create eval-bp1 breakpoint"
+ gdb_scm_test_silent_cmd "guile (define also-eval-bp1 (make-bp-also-eval \"$bp_location2\"))" \
+ "create also-eval-bp1 breakpoint"
+ gdb_scm_test_silent_cmd "guile (define never-eval-bp1 (make-bp-also-eval \"$end_location\"))" \
+ "create never-eval-bp1 breakpoint"
+ gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*"
+ gdb_test "print i" "3" "check inferior value matches guile accounting"
+ gdb_test "guile (print (bp-eval-inf-i eval-bp1))" \
+ "= 3" "check guile accounting matches inferior"
+ gdb_test "guile (print (bp-eval-count also-eval-bp1))" \
+ "= 4" \
+ "check non firing same-location breakpoint eval function was also called at each stop 1"
+ gdb_test "guile (print (bp-eval-count eval-bp1))" \
+ "= 4" \
+ "check non firing same-location breakpoint eval function was also called at each stop 2"
+
+ # Check we cannot assign a condition to a breakpoint with a stop-func,
+ # and cannot assign a stop-func to a breakpoint with a condition.
+
+ delete_breakpoints
+ set cond_bp [gdb_get_line_number "Break at multiply."]
+ gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$cond_bp\"))" \
+ "create eval-bp1 breakpoint 2"
+ set test_cond {cond $bpnum}
+ gdb_test "$test_cond \"foo==3\"" \
+ "Only one stop condition allowed.*"
+ gdb_scm_test_silent_cmd "guile (define eval-bp2 (make-bp-basic \"$cond_bp\"))" \
+ "create basic breakpoint"
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! eval-bp2 \"1==1\")" \
+ "set a condition"
+ gdb_test_multiline "construct an eval function" \
+ "guile" "" \
+ "(define (stop-func bkpt)" "" \
+ " return #t)" "" \
+ "end" ""
+ gdb_test "guile (set-breakpoint-stop! eval-bp2 stop-func)" \
+ "Only one stop condition allowed.*"
+
+ # Check that stop-func is run when location has normal bp.
+
+ delete_breakpoints
+ gdb_breakpoint [gdb_get_line_number "Break at multiply."]
+ gdb_scm_test_silent_cmd "guile (define check-eval (make-bp-eval \"$bp_location2\"))" \
+ "create check-eval breakpoint"
+ gdb_test "guile (print (bp-eval-count check-eval))" \
+ "= 0" \
+ "test that evaluate function has not been yet executed (ie count = 0)"
+ gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*"
+ gdb_test "guile (print (bp-eval-count check-eval))" \
+ "= 1" \
+ "test that evaluate function is run when location also has normal bp"
+
+ # Test watchpoints with stop-func.
+
+ gdb_test_multiline "watchpoint stop func" \
+ "guile" "" \
+ "(define (make-wp-eval location)" "" \
+ " (let ((wp (create-breakpoint! location #:type BP_WATCHPOINT #:wp-class WP_WRITE)))" "" \
+ " (set-breakpoint-stop! wp" "" \
+ " (lambda (bkpt)" "" \
+ " (let ((result (parse-and-eval \"result\")))" "" \
+ " (value=? result 788))))" "" \
+ " wp))" "" \
+ "end" ""
+
+ delete_breakpoints
+ gdb_scm_test_silent_cmd "guile (define wp1 (make-wp-eval \"result\"))" \
+ "create watchpoint"
+ gdb_test "continue" ".*\[Ww\]atchpoint.*result.*Old value =.*New value = 788.*" \
+ "test watchpoint write"
+
+ # Misc final tests.
+
+ gdb_test "guile (print (bp-eval-count never-eval-bp1))" \
+ "= 0" \
+ "check that this unrelated breakpoints eval function was never called"
+ }
+}
+
+test_bkpt_basic
+test_bkpt_deletion
+test_bkpt_cond_and_cmds
+test_bkpt_invisible
+test_watchpoints
+test_bkpt_internal
+test_bkpt_eval_funcs