gdb/guile/scm-breakpoint.c

/* Scheme interface to breakpoints.

   Copyright (C) 2008-2017 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 "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"
#include "location.h"

/* The <gdb:breakpoint> smob.
   N.B.: The name of this struct is known to breakpoint.h.

   Note: Breakpoints are added to gdb using a two step process:
   1) Call make-breakpoint to create a <gdb:breakpoint> object.
   2) Call register-breakpoint! to add the breakpoint to gdb.
   It is done this way so that the constructor, make-breakpoint, doesn't have
   any side-effects.  This means that the smob needs to store everything
   that was passed to make-breakpoint.  */

typedef struct gdbscm_breakpoint_object
{
  /* This always appears first.  */
  gdb_smob base;

  /* Non-zero if this breakpoint was created with make-breakpoint.  */
  int is_scheme_bkpt;

  /* For breakpoints created with make-breakpoint, these are the parameters
     that were passed to make-breakpoint.  These values are not used except
     to register the breakpoint with GDB.  */
  struct
  {
    /* The string representation of the breakpoint.
       Space for this lives in GC space.  */
    char *location;

    /* The kind of breakpoint.
       At the moment this can only be one of bp_breakpoint, bp_watchpoint.  */
    enum bptype type;

    /* If a watchpoint, the kind of watchpoint.  */
    enum target_hw_bp_type access_type;

    /* Non-zero if the breakpoint is an "internal" breakpoint.  */
    int is_internal;
  } spec;

  /* The breakpoint number according to gdb.
     For breakpoints created from Scheme, this has the value -1 until the
     breakpoint is registered with gdb.
     This is recorded here because BP will be NULL when deleted.  */
  int number;

  /* The gdb breakpoint object, or NULL if the breakpoint has not been
     registered yet, or 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 "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";
    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)
    {
      const char *str;

      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);

      str = event_location_to_string (b->location.get ());
      if (str != NULL)
	gdbscm_printf (port, " @%s", str);
    }

  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;

  memset (bp_smob, 0, sizeof (*bp_smob));
  bp_smob->number = -1;
  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.  */

/* (make-breakpoint string [#:type integer] [#:wp-class integer]
    [#:internal boolean) -> <gdb:breakpoint>

   The result is the <gdb:breakpoint> Scheme object.
   The breakpoint is not available to be used yet, however.
   It must still be added to gdb with register-breakpoint!.  */

static SCM
gdbscm_make_breakpoint (SCM location_scm, SCM rest)
{
  const SCM keywords[] = {
    type_keyword, wp_class_keyword, internal_keyword, SCM_BOOL_F
  };
  char *s;
  char *location;
  int type_arg_pos = -1, access_type_arg_pos = -1, internal_arg_pos = -1;
  enum bptype type = bp_breakpoint;
  enum target_hw_bp_type access_type = hw_write;
  int internal = 0;
  SCM result;
  breakpoint_smob *bp_smob;

  gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iit",
			      location_scm, &location, rest,
			      &type_arg_pos, &type,
			      &access_type_arg_pos, &access_type,
			      &internal_arg_pos, &internal);

  result = bpscm_make_breakpoint_smob ();
  bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (result);

  s = location;
  location = gdbscm_gc_xstrdup (s);
  xfree (s);

  switch (type)
    {
    case bp_breakpoint:
      if (access_type_arg_pos > 0)
	{
	  gdbscm_misc_error (FUNC_NAME, access_type_arg_pos,
			     scm_from_int (access_type),
			     _("access type with breakpoint is not allowed"));
	}
      break;
    case bp_watchpoint:
      switch (access_type)
	{
	case hw_write:
	case hw_access:
	case hw_read:
	  break;
	default:
	  gdbscm_out_of_range_error (FUNC_NAME, access_type_arg_pos,
				     scm_from_int (access_type),
				     _("invalid watchpoint class"));
	}
      break;
    default:
      gdbscm_out_of_range_error (FUNC_NAME, access_type_arg_pos,
				 scm_from_int (type),
				 _("invalid breakpoint type"));
    }

  bp_smob->is_scheme_bkpt = 1;
  bp_smob->spec.location = location;
  bp_smob->spec.type = type;
  bp_smob->spec.access_type = access_type;
  bp_smob->spec.is_internal = internal;

  return result;
}

/* (register-breakpoint! <gdb:breakpoint>) -> unspecified

   It is an error to register a breakpoint created outside of Guile,
   or an already-registered breakpoint.  */

static SCM
gdbscm_register_breakpoint_x (SCM self)
{
  breakpoint_smob *bp_smob
    = bpscm_get_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
  struct gdb_exception except = exception_none;
  char *location, *copy;

  /* We only support registering breakpoints created with make-breakpoint.  */
  if (!bp_smob->is_scheme_bkpt)
    scm_misc_error (FUNC_NAME, _("not a Scheme breakpoint"), SCM_EOL);

  if (bpscm_is_valid (bp_smob))
    scm_misc_error (FUNC_NAME, _("breakpoint is already registered"), SCM_EOL);

  pending_breakpoint_scm = self;
  location = bp_smob->spec.location;
  copy = skip_spaces (location);
  event_location_up eloc = string_to_event_location_basic (&copy,
							   current_language);

  TRY
    {
      int internal = bp_smob->spec.is_internal;

      switch (bp_smob->spec.type)
	{
	case bp_breakpoint:
	  {
	    create_breakpoint (get_current_arch (),
			       eloc.get (), NULL, -1, NULL,
			       0,
			       0, bp_breakpoint,
			       0,
			       AUTO_BOOLEAN_TRUE,
			       &bkpt_breakpoint_ops,
			       0, 1, internal, 0);
	    break;
	  }
	case bp_watchpoint:
	  {
	    enum target_hw_bp_type access_type = bp_smob->spec.access_type;

	    if (access_type == hw_write)
	      watch_command_wrapper (location, 0, internal);
	    else if (access_type == hw_access)
	      awatch_command_wrapper (location, 0, internal);
	    else if (access_type == hw_read)
	      rwatch_command_wrapper (location, 0, internal);
	    else
	      gdb_assert_not_reached ("invalid access type");
	    break;
	  }
	default:
	  gdb_assert_not_reached ("invalid breakpoint type");
	}
    }
  CATCH (ex, RETURN_MASK_ALL)
    {
      except = ex;
    }
  END_CATCH

  /* Ensure this gets reset, even if there's an error.  */
  pending_breakpoint_scm = SCM_BOOL_F;
  GDBSCM_HANDLE_GDB_EXCEPTION (except);

  return SCM_UNSPECIFIED;
}

/* (delete-breakpoint! <gdb:breakpoint>) -> unspecified
   Scheme function which deletes (removes) the underlying GDB breakpoint
   from GDB's list of breakpoints.  This triggers the breakpoint_deleted
   observer which will call gdbscm_breakpoint_deleted; that function cleans
   up the Scheme bits.  */

static SCM
gdbscm_delete_breakpoint_x (SCM self)
{
  breakpoint_smob *bp_smob
    = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);

  TRY
    {
      delete_breakpoint (bp_smob->bp);
    }
  CATCH (except, RETURN_MASK_ALL)
    {
      GDBSCM_HANDLE_GDB_EXCEPTION (except);
    }
  END_CATCH

  return SCM_UNSPECIFIED;
}

/* iterate_over_breakpoints function for gdbscm_breakpoints.  */

static int
bpscm_build_bp_list (struct breakpoint *bp, void *arg)
{
  SCM *list = (SCM *) 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);

  SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME,
		   _("boolean"));

  TRY
    {
      if (gdbscm_is_true (newvalue))
	enable_breakpoint (bp_smob->bp);
      else
	disable_breakpoint (bp_smob->bp);
    }
  CATCH (except, RETURN_MASK_ALL)
    {
      GDBSCM_HANDLE_GDB_EXCEPTION (except);
    }
  END_CATCH

  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);

  SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME,
		   _("boolean"));

  TRY
    {
      breakpoint_set_silent (bp_smob->bp, gdbscm_is_true (newvalue));
    }
  CATCH (except, RETURN_MASK_ALL)
    {
      GDBSCM_HANDLE_GDB_EXCEPTION (except);
    }
  END_CATCH

  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;

  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
    {
      set_ignore_count (bp_smob->number, (int) value, 0);
    }
  CATCH (except, RETURN_MASK_ALL)
    {
      GDBSCM_HANDLE_GDB_EXCEPTION (except);
    }
  END_CATCH

  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_global_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;

  if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
    {
      id = scm_to_long (newvalue);

      TRY
	{
	  valid_id = valid_task_id (id);
	}
      CATCH (except, RETURN_MASK_ALL)
	{
	  GDBSCM_HANDLE_GDB_EXCEPTION (except);
	}
      END_CATCH

      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
    {
      breakpoint_set_task (bp_smob->bp, id);
    }
  CATCH (except, RETURN_MASK_ALL)
    {
      GDBSCM_HANDLE_GDB_EXCEPTION (except);
    }
  END_CATCH

  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);
  const char *str;

  if (bp_smob->bp->type != bp_breakpoint)
    return SCM_BOOL_F;

  str = event_location_to_string (bp_smob->bp->location.get ());
  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);
  struct watchpoint *wp;

  if (!is_watchpoint (bp_smob->bp))
    return SCM_BOOL_F;

  wp = (struct watchpoint *) bp_smob->bp;

  const char *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;
  struct gdb_exception except = exception_none;

  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
    {
      set_breakpoint_condition (bp_smob->bp, exp ? exp : "", 0);
    }
  CATCH (ex, RETURN_MASK_ALL)
    {
      except = ex;
    }
  END_CATCH

  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 ((scm_t_dynwind_flags) 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;
  SCM result;

  bp = bp_smob->bp;

  if (bp->commands == NULL)
    return SCM_BOOL_F;

  string_file buf;

  current_uiout->redirect (&buf);
  TRY
    {
      print_command_lines (current_uiout, breakpoint_commands (bp), 0);
    }
  current_uiout->redirect (NULL);
  CATCH (except, RETURN_MASK_ALL)
    {
      gdbscm_throw_gdb_exception (except);
    }
  END_CATCH

  result = gdbscm_scm_from_c_string (buf.c_str ());

  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;
	  bp_smob->number = -1;
	  bp_smob->stop = SCM_BOOL_F;
	  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[] =
{
  { "make-breakpoint", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_breakpoint),
    "\
Create a GDB breakpoint object.\n\
\n\
  Arguments:\n\
    location [#:type <type>] [#:wp-class <wp-class>] [#:internal <bool>]\n\
  Returns:\n\
    <gdb:breakpoint object" },

  { "register-breakpoint!", 1, 0, 0,
    as_a_scm_t_subr (gdbscm_register_breakpoint_x),
    "\
Register a <gdb:breakpoint> object with GDB." },

  { "delete-breakpoint!", 1, 0, 0, as_a_scm_t_subr (gdbscm_delete_breakpoint_x),
    "\
Delete the breakpoint from GDB." },

  { "breakpoints", 0, 0, 0, as_a_scm_t_subr (gdbscm_breakpoints),
    "\
Return a list of all GDB breakpoints.\n\
\n\
  Arguments: none" },

  { "breakpoint?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_p),
    "\
Return #t if the object is a <gdb:breakpoint> object." },

  { "breakpoint-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_valid_p),
    "\
Return #t if the breakpoint has not been deleted from GDB." },

  { "breakpoint-number", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_number),
    "\
Return the breakpoint's number." },

  { "breakpoint-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_type),
    "\
Return the type of the breakpoint." },

  { "breakpoint-visible?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_visible),
    "\
Return #t if the breakpoint is visible to the user." },

  { "breakpoint-location", 1, 0, 0,
    as_a_scm_t_subr (gdbscm_breakpoint_location),
    "\
Return the location of the breakpoint as specified by the user." },

  { "breakpoint-expression", 1, 0, 0,
    as_a_scm_t_subr (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,
    as_a_scm_t_subr (gdbscm_breakpoint_enabled_p),
    "\
Return #t if the breakpoint is enabled." },

  { "set-breakpoint-enabled!", 2, 0, 0,
    as_a_scm_t_subr (gdbscm_set_breakpoint_enabled_x),
    "\
Set the breakpoint's enabled state.\n\
\n\
  Arguments: <gdb:breakpoint> boolean" },

  { "breakpoint-silent?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_silent_p),
    "\
Return #t if the breakpoint is silent." },

  { "set-breakpoint-silent!", 2, 0, 0,
    as_a_scm_t_subr (gdbscm_set_breakpoint_silent_x),
    "\
Set the breakpoint's silent state.\n\
\n\
  Arguments: <gdb:breakpoint> boolean" },

  { "breakpoint-ignore-count", 1, 0, 0,
    as_a_scm_t_subr (gdbscm_breakpoint_ignore_count),
    "\
Return the breakpoint's \"ignore\" count." },

  { "set-breakpoint-ignore-count!", 2, 0, 0,
    as_a_scm_t_subr (gdbscm_set_breakpoint_ignore_count_x),
    "\
Set the breakpoint's \"ignore\" count.\n\
\n\
  Arguments: <gdb:breakpoint> count" },

  { "breakpoint-hit-count", 1, 0, 0,
    as_a_scm_t_subr (gdbscm_breakpoint_hit_count),
    "\
Return the breakpoint's \"hit\" count." },

  { "set-breakpoint-hit-count!", 2, 0, 0,
    as_a_scm_t_subr (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, as_a_scm_t_subr (gdbscm_breakpoint_thread),
    "\
Return the breakpoint's global thread id or #f if there isn't one." },

  { "set-breakpoint-thread!", 2, 0, 0,
    as_a_scm_t_subr (gdbscm_set_breakpoint_thread_x),
    "\
Set the global thread id for this breakpoint.\n\
\n\
  Arguments: <gdb:breakpoint> global-thread-id" },

  { "breakpoint-task", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_task),
    "\
Return the breakpoint's Ada task-id or #f if there isn't one." },

  { "set-breakpoint-task!", 2, 0, 0,
    as_a_scm_t_subr (gdbscm_set_breakpoint_task_x),
    "\
Set the breakpoint's Ada task-id.\n\
\n\
  Arguments: <gdb:breakpoint> task-id" },

  { "breakpoint-condition", 1, 0, 0,
    as_a_scm_t_subr (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,
    as_a_scm_t_subr (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, as_a_scm_t_subr (gdbscm_breakpoint_stop),
    "\
Return the breakpoint's stop predicate.\n\
Return #f if there isn't one." },

  { "set-breakpoint-stop!", 2, 0, 0,
    as_a_scm_t_subr (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,
    as_a_scm_t_subr (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_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");
}