gdb/guile/scm-breakpoint.c

   1 /* Scheme interface to breakpoints.
   2
   3    Copyright (C) 2008-2022 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 /* See README file in this directory for implementation notes, coding
  21    conventions, et.al.  */
  22
  23 #include "defs.h"
  24 #include "value.h"
  25 #include "breakpoint.h"
  26 #include "gdbcmd.h"
  27 #include "gdbthread.h"
  28 #include "observable.h"
  29 #include "cli/cli-script.h"
  30 #include "ada-lang.h"
  31 #include "arch-utils.h"
  32 #include "language.h"
  33 #include "guile-internal.h"
  34 #include "location.h"
  35
  36 /* The <gdb:breakpoint> smob.
  37    N.B.: The name of this struct is known to breakpoint.h.
  38
  39    Note: Breakpoints are added to gdb using a two step process:
  40    1) Call make-breakpoint to create a <gdb:breakpoint> object.
  41    2) Call register-breakpoint! to add the breakpoint to gdb.
  42    It is done this way so that the constructor, make-breakpoint, doesn't have
  43    any side-effects.  This means that the smob needs to store everything
  44    that was passed to make-breakpoint.  */
  45
  46 typedef struct gdbscm_breakpoint_object
  47 {
  48   /* This always appears first.  */
  49   gdb_smob base;
  50
  51   /* Non-zero if this breakpoint was created with make-breakpoint.  */
  52   int is_scheme_bkpt;
  53
  54   /* For breakpoints created with make-breakpoint, these are the parameters
  55      that were passed to make-breakpoint.  These values are not used except
  56      to register the breakpoint with GDB.  */
  57   struct
  58   {
  59     /* The string representation of the breakpoint.
  60        Space for this lives in GC space.  */
  61     char *location;
  62
  63     /* The kind of breakpoint.
  64        At the moment this can only be one of bp_breakpoint, bp_watchpoint.  */
  65     enum bptype type;
  66
  67     /* If a watchpoint, the kind of watchpoint.  */
  68     enum target_hw_bp_type access_type;
  69
  70     /* Non-zero if the breakpoint is an "internal" breakpoint.  */
  71     int is_internal;
  72
  73     /* Non-zero if the breakpoint is temporary.  */
  74     int is_temporary;
  75   } spec;
  76
  77   /* The breakpoint number according to gdb.
  78      For breakpoints created from Scheme, this has the value -1 until the
  79      breakpoint is registered with gdb.
  80      This is recorded here because BP will be NULL when deleted.  */
  81   int number;
  82
  83   /* The gdb breakpoint object, or NULL if the breakpoint has not been
  84      registered yet, or has been deleted.  */
  85   struct breakpoint *bp;
  86
  87   /* Backlink to our containing <gdb:breakpoint> smob.
  88      This is needed when we are deleted, we need to unprotect the object
  89      from GC.  */
  90   SCM containing_scm;
  91
  92   /* A stop condition or #f.  */
  93   SCM stop;
  94 } breakpoint_smob;
  95
  96 static const char breakpoint_smob_name[] = "gdb:breakpoint";
  97
  98 /* The tag Guile knows the breakpoint smob by.  */
  99 static scm_t_bits breakpoint_smob_tag;
 100
 101 /* Variables used to pass information between the breakpoint_smob
 102    constructor and the breakpoint-created hook function.  */
 103 static SCM pending_breakpoint_scm = SCM_BOOL_F;
 104
 105 /* Keywords used by create-breakpoint!.  */
 106 static SCM type_keyword;
 107 static SCM wp_class_keyword;
 108 static SCM internal_keyword;
 109 static SCM temporary_keyword;
 110 \f
 111 /* Administrivia for breakpoint smobs.  */
 112
 113 /* The smob "free" function for <gdb:breakpoint>.  */
 114
 115 static size_t
 116 bpscm_free_breakpoint_smob (SCM self)
 117 {
 118   breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self);
 119
 120   if (bp_smob->bp)
 121     bp_smob->bp->scm_bp_object = NULL;
 122
 123   /* Not necessary, done to catch bugs.  */
 124   bp_smob->bp = NULL;
 125   bp_smob->containing_scm = SCM_UNDEFINED;
 126   bp_smob->stop = SCM_UNDEFINED;
 127
 128   return 0;
 129 }
 130
 131 /* Return the name of TYPE.
 132    This doesn't handle all types, just the ones we export.  */
 133
 134 static const char *
 135 bpscm_type_to_string (enum bptype type)
 136 {
 137   switch (type)
 138     {
 139     case bp_none: return "BP_NONE";
 140     case bp_breakpoint: return "BP_BREAKPOINT";
 141     case bp_watchpoint: return "BP_WATCHPOINT";
 142     case bp_hardware_watchpoint: return "BP_HARDWARE_WATCHPOINT";
 143     case bp_read_watchpoint: return "BP_READ_WATCHPOINT";
 144     case bp_access_watchpoint: return "BP_ACCESS_WATCHPOINT";
 145     case bp_catchpoint: return "BP_CATCHPOINT";
 146     default: return "internal/other";
 147     }
 148 }
 149
 150 /* Return the name of ENABLE_STATE.  */
 151
 152 static const char *
 153 bpscm_enable_state_to_string (enum enable_state enable_state)
 154 {
 155   switch (enable_state)
 156     {
 157     case bp_disabled: return "disabled";
 158     case bp_enabled: return "enabled";
 159     case bp_call_disabled: return "call_disabled";
 160     default: return "unknown";
 161     }
 162 }
 163
 164 /* The smob "print" function for <gdb:breakpoint>.  */
 165
 166 static int
 167 bpscm_print_breakpoint_smob (SCM self, SCM port, scm_print_state *pstate)
 168 {
 169   breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self);
 170   struct breakpoint *b = bp_smob->bp;
 171
 172   gdbscm_printf (port, "#<%s", breakpoint_smob_name);
 173
 174   /* Only print what we export to the user.
 175      The rest are possibly internal implementation details.  */
 176
 177   gdbscm_printf (port, " #%d", bp_smob->number);
 178
 179   /* Careful, the breakpoint may be invalid.  */
 180   if (b != NULL)
 181     {
 182       gdbscm_printf (port, " %s %s %s",
 183                      bpscm_type_to_string (b->type),
 184                      bpscm_enable_state_to_string (b->enable_state),
 185                      b->silent ? "silent" : "noisy");
 186
 187       gdbscm_printf (port, " hit:%d", b->hit_count);
 188       gdbscm_printf (port, " ignore:%d", b->ignore_count);
 189
 190       if (b->location != nullptr)
 191         {
 192           const char *str = event_location_to_string (b->location.get ());
 193           if (str != nullptr)
 194             gdbscm_printf (port, " @%s", str);
 195         }
 196     }
 197
 198   scm_puts (">", port);
 199
 200   scm_remember_upto_here_1 (self);
 201
 202   /* Non-zero means success.  */
 203   return 1;
 204 }
 205
 206 /* Low level routine to create a <gdb:breakpoint> object.  */
 207
 208 static SCM
 209 bpscm_make_breakpoint_smob (void)
 210 {
 211   breakpoint_smob *bp_smob = (breakpoint_smob *)
 212     scm_gc_malloc (sizeof (breakpoint_smob), breakpoint_smob_name);
 213   SCM bp_scm;
 214
 215   memset (bp_smob, 0, sizeof (*bp_smob));
 216   bp_smob->number = -1;
 217   bp_smob->stop = SCM_BOOL_F;
 218   bp_scm = scm_new_smob (breakpoint_smob_tag, (scm_t_bits) bp_smob);
 219   bp_smob->containing_scm = bp_scm;
 220   gdbscm_init_gsmob (&bp_smob->base);
 221
 222   return bp_scm;
 223 }
 224
 225 /* Return non-zero if we want a Scheme wrapper for breakpoint B.
 226    If FROM_SCHEME is non-zero,this is called for a breakpoint created
 227    by the user from Scheme.  Otherwise it is zero.  */
 228
 229 static int
 230 bpscm_want_scm_wrapper_p (struct breakpoint *bp, int from_scheme)
 231 {
 232   /* Don't create <gdb:breakpoint> objects for internal GDB breakpoints.  */
 233   if (bp->number < 0 && !from_scheme)
 234     return 0;
 235
 236   /* The others are not supported.  */
 237   if (bp->type != bp_breakpoint
 238       && bp->type != bp_watchpoint
 239       && bp->type != bp_hardware_watchpoint
 240       && bp->type != bp_read_watchpoint
 241       && bp->type != bp_access_watchpoint
 242       && bp->type != bp_catchpoint)
 243     return 0;
 244
 245   return 1;
 246 }
 247
 248 /* Install the Scheme side of a breakpoint, CONTAINING_SCM, in
 249    the gdb side BP.  */
 250
 251 static void
 252 bpscm_attach_scm_to_breakpoint (struct breakpoint *bp, SCM containing_scm)
 253 {
 254   breakpoint_smob *bp_smob;
 255
 256   bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (containing_scm);
 257   bp_smob->number = bp->number;
 258   bp_smob->bp = bp;
 259   bp_smob->containing_scm = containing_scm;
 260   bp_smob->bp->scm_bp_object = bp_smob;
 261
 262   /* The owner of this breakpoint is not in GC-controlled memory, so we need
 263      to protect it from GC until the breakpoint is deleted.  */
 264   scm_gc_protect_object (containing_scm);
 265 }
 266
 267 /* Return non-zero if SCM is a breakpoint smob.  */
 268
 269 static int
 270 bpscm_is_breakpoint (SCM scm)
 271 {
 272   return SCM_SMOB_PREDICATE (breakpoint_smob_tag, scm);
 273 }
 274
 275 /* (breakpoint? scm) -> boolean */
 276
 277 static SCM
 278 gdbscm_breakpoint_p (SCM scm)
 279 {
 280   return scm_from_bool (bpscm_is_breakpoint (scm));
 281 }
 282
 283 /* Returns the <gdb:breakpoint> object in SELF.
 284    Throws an exception if SELF is not a <gdb:breakpoint> object.  */
 285
 286 static SCM
 287 bpscm_get_breakpoint_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 288 {
 289   SCM_ASSERT_TYPE (bpscm_is_breakpoint (self), self, arg_pos, func_name,
 290                    breakpoint_smob_name);
 291
 292   return self;
 293 }
 294
 295 /* Returns a pointer to the breakpoint smob of SELF.
 296    Throws an exception if SELF is not a <gdb:breakpoint> object.  */
 297
 298 static breakpoint_smob *
 299 bpscm_get_breakpoint_smob_arg_unsafe (SCM self, int arg_pos,
 300                                       const char *func_name)
 301 {
 302   SCM bp_scm = bpscm_get_breakpoint_arg_unsafe (self, arg_pos, func_name);
 303   breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (bp_scm);
 304
 305   return bp_smob;
 306 }
 307
 308 /* Return non-zero if breakpoint BP_SMOB is valid.  */
 309
 310 static int
 311 bpscm_is_valid (breakpoint_smob *bp_smob)
 312 {
 313   return bp_smob->bp != NULL;
 314 }
 315
 316 /* Returns the breakpoint smob in SELF, verifying it's valid.
 317    Throws an exception if SELF is not a <gdb:breakpoint> object,
 318    or is invalid.  */
 319
 320 static breakpoint_smob *
 321 bpscm_get_valid_breakpoint_smob_arg_unsafe (SCM self, int arg_pos,
 322                                             const char *func_name)
 323 {
 324   breakpoint_smob *bp_smob
 325     = bpscm_get_breakpoint_smob_arg_unsafe (self, arg_pos, func_name);
 326
 327   if (!bpscm_is_valid (bp_smob))
 328     {
 329       gdbscm_invalid_object_error (func_name, arg_pos, self,
 330                                    _("<gdb:breakpoint>"));
 331     }
 332
 333   return bp_smob;
 334 }
 335 \f
 336 /* Breakpoint methods.  */
 337
 338 /* (make-breakpoint string [#:type integer] [#:wp-class integer]
 339     [#:internal boolean] [#:temporary boolean]) -> <gdb:breakpoint>
 340
 341    The result is the <gdb:breakpoint> Scheme object.
 342    The breakpoint is not available to be used yet, however.
 343    It must still be added to gdb with register-breakpoint!.  */
 344
 345 static SCM
 346 gdbscm_make_breakpoint (SCM location_scm, SCM rest)
 347 {
 348   const SCM keywords[] = {
 349     type_keyword, wp_class_keyword, internal_keyword,
 350     temporary_keyword, SCM_BOOL_F
 351   };
 352   char *s;
 353   char *location;
 354   int type_arg_pos = -1, access_type_arg_pos = -1,
 355       internal_arg_pos = -1, temporary_arg_pos = -1;
 356   int type = bp_breakpoint;
 357   int access_type = hw_write;
 358   int internal = 0;
 359   int temporary = 0;
 360   SCM result;
 361   breakpoint_smob *bp_smob;
 362
 363   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iitt",
 364                               location_scm, &location, rest,
 365                               &type_arg_pos, &type,
 366                               &access_type_arg_pos, &access_type,
 367                               &internal_arg_pos, &internal,
 368                               &temporary_arg_pos, &temporary);
 369
 370   result = bpscm_make_breakpoint_smob ();
 371   bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (result);
 372
 373   s = location;
 374   location = gdbscm_gc_xstrdup (s);
 375   xfree (s);
 376
 377   switch (type)
 378     {
 379     case bp_breakpoint:
 380       if (access_type_arg_pos > 0)
 381         {
 382           gdbscm_misc_error (FUNC_NAME, access_type_arg_pos,
 383                              scm_from_int (access_type),
 384                              _("access type with breakpoint is not allowed"));
 385         }
 386       break;
 387     case bp_watchpoint:
 388       switch (access_type)
 389         {
 390         case hw_write:
 391         case hw_access:
 392         case hw_read:
 393           break;
 394         default:
 395           gdbscm_out_of_range_error (FUNC_NAME, access_type_arg_pos,
 396                                      scm_from_int (access_type),
 397                                      _("invalid watchpoint class"));
 398         }
 399       break;
 400     case bp_none:
 401     case bp_hardware_watchpoint:
 402     case bp_read_watchpoint:
 403     case bp_access_watchpoint:
 404     case bp_catchpoint:
 405       {
 406         const char *type_name = bpscm_type_to_string ((enum bptype) type);
 407         gdbscm_misc_error (FUNC_NAME, type_arg_pos,
 408                            gdbscm_scm_from_c_string (type_name),
 409                            _("unsupported breakpoint type"));
 410       }
 411       break;
 412     default:
 413       gdbscm_out_of_range_error (FUNC_NAME, type_arg_pos,
 414                                  scm_from_int (type),
 415                                  _("invalid breakpoint type"));
 416     }
 417
 418   bp_smob->is_scheme_bkpt = 1;
 419   bp_smob->spec.location = location;
 420   bp_smob->spec.type = (enum bptype) type;
 421   bp_smob->spec.access_type = (enum target_hw_bp_type) access_type;
 422   bp_smob->spec.is_internal = internal;
 423   bp_smob->spec.is_temporary = temporary;
 424
 425   return result;
 426 }
 427
 428 /* (register-breakpoint! <gdb:breakpoint>) -> unspecified
 429
 430    It is an error to register a breakpoint created outside of Guile,
 431    or an already-registered breakpoint.  */
 432
 433 static SCM
 434 gdbscm_register_breakpoint_x (SCM self)
 435 {
 436   breakpoint_smob *bp_smob
 437     = bpscm_get_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 438   gdbscm_gdb_exception except {};
 439   const char *location, *copy;
 440
 441   /* We only support registering breakpoints created with make-breakpoint.  */
 442   if (!bp_smob->is_scheme_bkpt)
 443     scm_misc_error (FUNC_NAME, _("not a Scheme breakpoint"), SCM_EOL);
 444
 445   if (bpscm_is_valid (bp_smob))
 446     scm_misc_error (FUNC_NAME, _("breakpoint is already registered"), SCM_EOL);
 447
 448   pending_breakpoint_scm = self;
 449   location = bp_smob->spec.location;
 450   copy = skip_spaces (location);
 451   event_location_up eloc
 452     = string_to_event_location_basic (&copy,
 453                                       current_language,
 454                                       symbol_name_match_type::WILD);
 455
 456   try
 457     {
 458       int internal = bp_smob->spec.is_internal;
 459       int temporary = bp_smob->spec.is_temporary;
 460
 461       switch (bp_smob->spec.type)
 462         {
 463         case bp_breakpoint:
 464           {
 465             const breakpoint_ops *ops =
 466               breakpoint_ops_for_event_location (eloc.get (), false);
 467             create_breakpoint (get_current_arch (),
 468                                eloc.get (), NULL, -1, NULL, false,
 469                                0,
 470                                temporary, bp_breakpoint,
 471                                0,
 472                                AUTO_BOOLEAN_TRUE,
 473                                ops,
 474                                0, 1, internal, 0);
 475             break;
 476           }
 477         case bp_watchpoint:
 478           {
 479             enum target_hw_bp_type access_type = bp_smob->spec.access_type;
 480
 481             if (access_type == hw_write)
 482               watch_command_wrapper (location, 0, internal);
 483             else if (access_type == hw_access)
 484               awatch_command_wrapper (location, 0, internal);
 485             else if (access_type == hw_read)
 486               rwatch_command_wrapper (location, 0, internal);
 487             else
 488               gdb_assert_not_reached ("invalid access type");
 489             break;
 490           }
 491         default:
 492           gdb_assert_not_reached ("invalid breakpoint type");
 493         }
 494     }
 495   catch (const gdb_exception &ex)
 496     {
 497       except = unpack (ex);
 498     }
 499
 500   /* Ensure this gets reset, even if there's an error.  */
 501   pending_breakpoint_scm = SCM_BOOL_F;
 502   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 503
 504   return SCM_UNSPECIFIED;
 505 }
 506
 507 /* (delete-breakpoint! <gdb:breakpoint>) -> unspecified
 508    Scheme function which deletes (removes) the underlying GDB breakpoint
 509    from GDB's list of breakpoints.  This triggers the breakpoint_deleted
 510    observer which will call gdbscm_breakpoint_deleted; that function cleans
 511    up the Scheme bits.  */
 512
 513 static SCM
 514 gdbscm_delete_breakpoint_x (SCM self)
 515 {
 516   breakpoint_smob *bp_smob
 517     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 518
 519   gdbscm_gdb_exception exc {};
 520   try
 521     {
 522       delete_breakpoint (bp_smob->bp);
 523     }
 524   catch (const gdb_exception &except)
 525     {
 526       exc = unpack (except);
 527     }
 528
 529   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 530   return SCM_UNSPECIFIED;
 531 }
 532
 533 /* iterate_over_breakpoints function for gdbscm_breakpoints.  */
 534
 535 static void
 536 bpscm_build_bp_list (struct breakpoint *bp, SCM *list)
 537 {
 538   breakpoint_smob *bp_smob = bp->scm_bp_object;
 539
 540   /* Lazily create wrappers for breakpoints created outside Scheme.  */
 541
 542   if (bp_smob == NULL)
 543     {
 544       if (bpscm_want_scm_wrapper_p (bp, 0))
 545         {
 546           SCM bp_scm;
 547
 548           bp_scm = bpscm_make_breakpoint_smob ();
 549           bpscm_attach_scm_to_breakpoint (bp, bp_scm);
 550           /* Refetch it.  */
 551           bp_smob = bp->scm_bp_object;
 552         }
 553     }
 554
 555   /* Not all breakpoints will have a companion Scheme object.
 556      Only breakpoints that trigger the created_breakpoint observer call,
 557      and satisfy certain conditions (see bpscm_want_scm_wrapper_p),
 558      get a companion object (this includes Scheme-created breakpoints).  */
 559
 560   if (bp_smob != NULL)
 561     *list = scm_cons (bp_smob->containing_scm, *list);
 562 }
 563
 564 /* (breakpoints) -> list
 565    Return a list of all breakpoints.  */
 566
 567 static SCM
 568 gdbscm_breakpoints (void)
 569 {
 570   SCM list = SCM_EOL;
 571
 572   for (breakpoint *bp : all_breakpoints ())
 573     bpscm_build_bp_list (bp, &list);
 574
 575   return scm_reverse_x (list, SCM_EOL);
 576 }
 577
 578 /* (breakpoint-valid? <gdb:breakpoint>) -> boolean
 579    Returns #t if SELF is still valid.  */
 580
 581 static SCM
 582 gdbscm_breakpoint_valid_p (SCM self)
 583 {
 584   breakpoint_smob *bp_smob
 585     = bpscm_get_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 586
 587   return scm_from_bool (bpscm_is_valid (bp_smob));
 588 }
 589
 590 /* (breakpoint-enabled? <gdb:breakpoint>) -> boolean */
 591
 592 static SCM
 593 gdbscm_breakpoint_enabled_p (SCM self)
 594 {
 595   breakpoint_smob *bp_smob
 596     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 597
 598   return scm_from_bool (bp_smob->bp->enable_state == bp_enabled);
 599 }
 600
 601 /* (set-breakpoint-enabled? <gdb:breakpoint> boolean) -> unspecified */
 602
 603 static SCM
 604 gdbscm_set_breakpoint_enabled_x (SCM self, SCM newvalue)
 605 {
 606   breakpoint_smob *bp_smob
 607     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 608
 609   SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME,
 610                    _("boolean"));
 611
 612   gdbscm_gdb_exception exc {};
 613   try
 614     {
 615       if (gdbscm_is_true (newvalue))
 616         enable_breakpoint (bp_smob->bp);
 617       else
 618         disable_breakpoint (bp_smob->bp);
 619     }
 620   catch (const gdb_exception &except)
 621     {
 622       exc = unpack (except);
 623     }
 624
 625   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 626   return SCM_UNSPECIFIED;
 627 }
 628
 629 /* (breakpoint-silent? <gdb:breakpoint>) -> boolean */
 630
 631 static SCM
 632 gdbscm_breakpoint_silent_p (SCM self)
 633 {
 634   breakpoint_smob *bp_smob
 635     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 636
 637   return scm_from_bool (bp_smob->bp->silent);
 638 }
 639
 640 /* (set-breakpoint-silent?! <gdb:breakpoint> boolean) -> unspecified */
 641
 642 static SCM
 643 gdbscm_set_breakpoint_silent_x (SCM self, SCM newvalue)
 644 {
 645   breakpoint_smob *bp_smob
 646     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 647
 648   SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME,
 649                    _("boolean"));
 650
 651   gdbscm_gdb_exception exc {};
 652   try
 653     {
 654       breakpoint_set_silent (bp_smob->bp, gdbscm_is_true (newvalue));
 655     }
 656   catch (const gdb_exception &except)
 657     {
 658       exc = unpack (except);
 659     }
 660
 661   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 662   return SCM_UNSPECIFIED;
 663 }
 664
 665 /* (breakpoint-ignore-count <gdb:breakpoint>) -> integer */
 666
 667 static SCM
 668 gdbscm_breakpoint_ignore_count (SCM self)
 669 {
 670   breakpoint_smob *bp_smob
 671     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 672
 673   return scm_from_long (bp_smob->bp->ignore_count);
 674 }
 675
 676 /* (set-breakpoint-ignore-count! <gdb:breakpoint> integer)
 677      -> unspecified */
 678
 679 static SCM
 680 gdbscm_set_breakpoint_ignore_count_x (SCM self, SCM newvalue)
 681 {
 682   breakpoint_smob *bp_smob
 683     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 684   long value;
 685
 686   SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX),
 687                    newvalue, SCM_ARG2, FUNC_NAME, _("integer"));
 688
 689   value = scm_to_long (newvalue);
 690   if (value < 0)
 691     value = 0;
 692
 693   gdbscm_gdb_exception exc {};
 694   try
 695     {
 696       set_ignore_count (bp_smob->number, (int) value, 0);
 697     }
 698   catch (const gdb_exception &except)
 699     {
 700       exc = unpack (except);
 701     }
 702
 703   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 704   return SCM_UNSPECIFIED;
 705 }
 706
 707 /* (breakpoint-hit-count <gdb:breakpoint>) -> integer */
 708
 709 static SCM
 710 gdbscm_breakpoint_hit_count (SCM self)
 711 {
 712   breakpoint_smob *bp_smob
 713     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 714
 715   return scm_from_long (bp_smob->bp->hit_count);
 716 }
 717
 718 /* (set-breakpoint-hit-count! <gdb:breakpoint> integer) -> unspecified */
 719
 720 static SCM
 721 gdbscm_set_breakpoint_hit_count_x (SCM self, SCM newvalue)
 722 {
 723   breakpoint_smob *bp_smob
 724     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 725   long value;
 726
 727   SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX),
 728                    newvalue, SCM_ARG2, FUNC_NAME, _("integer"));
 729
 730   value = scm_to_long (newvalue);
 731   if (value < 0)
 732     value = 0;
 733
 734   if (value != 0)
 735     {
 736       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 737                                  _("hit-count must be zero"));
 738     }
 739
 740   bp_smob->bp->hit_count = 0;
 741
 742   return SCM_UNSPECIFIED;
 743 }
 744
 745 /* (breakpoint-thread <gdb:breakpoint>) -> integer */
 746
 747 static SCM
 748 gdbscm_breakpoint_thread (SCM self)
 749 {
 750   breakpoint_smob *bp_smob
 751     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 752
 753   if (bp_smob->bp->thread == -1)
 754     return SCM_BOOL_F;
 755
 756   return scm_from_long (bp_smob->bp->thread);
 757 }
 758
 759 /* (set-breakpoint-thread! <gdb:breakpoint> integer) -> unspecified */
 760
 761 static SCM
 762 gdbscm_set_breakpoint_thread_x (SCM self, SCM newvalue)
 763 {
 764   breakpoint_smob *bp_smob
 765     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 766   long id;
 767
 768   if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
 769     {
 770       id = scm_to_long (newvalue);
 771       if (!valid_global_thread_id (id))
 772         {
 773           gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 774                                      _("invalid thread id"));
 775         }
 776     }
 777   else if (gdbscm_is_false (newvalue))
 778     id = -1;
 779   else
 780     SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f"));
 781
 782   breakpoint_set_thread (bp_smob->bp, id);
 783
 784   return SCM_UNSPECIFIED;
 785 }
 786
 787 /* (breakpoint-task <gdb:breakpoint>) -> integer */
 788
 789 static SCM
 790 gdbscm_breakpoint_task (SCM self)
 791 {
 792   breakpoint_smob *bp_smob
 793     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 794
 795   if (bp_smob->bp->task == 0)
 796     return SCM_BOOL_F;
 797
 798   return scm_from_long (bp_smob->bp->task);
 799 }
 800
 801 /* (set-breakpoint-task! <gdb:breakpoint> integer) -> unspecified */
 802
 803 static SCM
 804 gdbscm_set_breakpoint_task_x (SCM self, SCM newvalue)
 805 {
 806   breakpoint_smob *bp_smob
 807     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 808   long id;
 809   int valid_id = 0;
 810
 811   if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
 812     {
 813       id = scm_to_long (newvalue);
 814
 815       gdbscm_gdb_exception exc {};
 816       try
 817         {
 818           valid_id = valid_task_id (id);
 819         }
 820       catch (const gdb_exception &except)
 821         {
 822           exc = unpack (except);
 823         }
 824
 825       GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 826       if (! valid_id)
 827         {
 828           gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 829                                      _("invalid task id"));
 830         }
 831     }
 832   else if (gdbscm_is_false (newvalue))
 833     id = 0;
 834   else
 835     SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f"));
 836
 837   gdbscm_gdb_exception exc {};
 838   try
 839     {
 840       breakpoint_set_task (bp_smob->bp, id);
 841     }
 842   catch (const gdb_exception &except)
 843     {
 844       exc = unpack (except);
 845     }
 846
 847   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 848   return SCM_UNSPECIFIED;
 849 }
 850
 851 /* (breakpoint-location <gdb:breakpoint>) -> string */
 852
 853 static SCM
 854 gdbscm_breakpoint_location (SCM self)
 855 {
 856   breakpoint_smob *bp_smob
 857     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 858   const char *str;
 859
 860   if (bp_smob->bp->type != bp_breakpoint)
 861     return SCM_BOOL_F;
 862
 863   str = event_location_to_string (bp_smob->bp->location.get ());
 864   if (! str)
 865     str = "";
 866
 867   return gdbscm_scm_from_c_string (str);
 868 }
 869
 870 /* (breakpoint-expression <gdb:breakpoint>) -> string
 871    This is only valid for watchpoints.
 872    Returns #f for non-watchpoints.  */
 873
 874 static SCM
 875 gdbscm_breakpoint_expression (SCM self)
 876 {
 877   breakpoint_smob *bp_smob
 878     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 879   struct watchpoint *wp;
 880
 881   if (!is_watchpoint (bp_smob->bp))
 882     return SCM_BOOL_F;
 883
 884   wp = (struct watchpoint *) bp_smob->bp;
 885
 886   const char *str = wp->exp_string.get ();
 887   if (! str)
 888     str = "";
 889
 890   return gdbscm_scm_from_c_string (str);
 891 }
 892
 893 /* (breakpoint-condition <gdb:breakpoint>) -> string */
 894
 895 static SCM
 896 gdbscm_breakpoint_condition (SCM self)
 897 {
 898   breakpoint_smob *bp_smob
 899     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 900   char *str;
 901
 902   str = bp_smob->bp->cond_string.get ();
 903   if (! str)
 904     return SCM_BOOL_F;
 905
 906   return gdbscm_scm_from_c_string (str);
 907 }
 908
 909 /* (set-breakpoint-condition! <gdb:breakpoint> string|#f)
 910    -> unspecified */
 911
 912 static SCM
 913 gdbscm_set_breakpoint_condition_x (SCM self, SCM newvalue)
 914 {
 915   breakpoint_smob *bp_smob
 916     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 917
 918   SCM_ASSERT_TYPE (scm_is_string (newvalue) || gdbscm_is_false (newvalue),
 919                    newvalue, SCM_ARG2, FUNC_NAME,
 920                    _("string or #f"));
 921
 922   return gdbscm_wrap ([=]
 923     {
 924       gdb::unique_xmalloc_ptr<char> exp
 925         = (gdbscm_is_false (newvalue)
 926            ? nullptr
 927            : gdbscm_scm_to_c_string (newvalue));
 928
 929       set_breakpoint_condition (bp_smob->bp, exp ? exp.get () : "", 0, false);
 930
 931       return SCM_UNSPECIFIED;
 932     });
 933 }
 934
 935 /* (breakpoint-stop <gdb:breakpoint>) -> procedure or #f */
 936
 937 static SCM
 938 gdbscm_breakpoint_stop (SCM self)
 939 {
 940   breakpoint_smob *bp_smob
 941     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 942
 943   return bp_smob->stop;
 944 }
 945
 946 /* (set-breakpoint-stop! <gdb:breakpoint> procedure|#f)
 947    -> unspecified */
 948
 949 static SCM
 950 gdbscm_set_breakpoint_stop_x (SCM self, SCM newvalue)
 951 {
 952   breakpoint_smob *bp_smob
 953     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 954   const struct extension_language_defn *extlang = NULL;
 955
 956   SCM_ASSERT_TYPE (gdbscm_is_procedure (newvalue)
 957                    || gdbscm_is_false (newvalue),
 958                    newvalue, SCM_ARG2, FUNC_NAME,
 959                    _("procedure or #f"));
 960
 961   if (bp_smob->bp->cond_string != NULL)
 962     extlang = get_ext_lang_defn (EXT_LANG_GDB);
 963   if (extlang == NULL)
 964     extlang = get_breakpoint_cond_ext_lang (bp_smob->bp, EXT_LANG_GUILE);
 965   if (extlang != NULL)
 966     {
 967       char *error_text
 968         = xstrprintf (_("Only one stop condition allowed.  There is"
 969                         " currently a %s stop condition defined for"
 970                         " this breakpoint."),
 971                       ext_lang_capitalized_name (extlang)).release ();
 972
 973       scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 974       gdbscm_dynwind_xfree (error_text);
 975       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self, error_text);
 976       /* The following line, while unnecessary, is present for completeness
 977          sake.  */
 978       scm_dynwind_end ();
 979     }
 980
 981   bp_smob->stop = newvalue;
 982
 983   return SCM_UNSPECIFIED;
 984 }
 985
 986 /* (breakpoint-commands <gdb:breakpoint>) -> string */
 987
 988 static SCM
 989 gdbscm_breakpoint_commands (SCM self)
 990 {
 991   breakpoint_smob *bp_smob
 992     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 993   struct breakpoint *bp;
 994   SCM result;
 995
 996   bp = bp_smob->bp;
 997
 998   if (bp->commands == NULL)
 999     return SCM_BOOL_F;
1000
1001   string_file buf;
1002
1003   current_uiout->redirect (&buf);
1004   gdbscm_gdb_exception exc {};
1005   try
1006     {
1007       print_command_lines (current_uiout, breakpoint_commands (bp), 0);
1008     }
1009   catch (const gdb_exception &except)
1010     {
1011       exc = unpack (except);
1012     }
1013
1014   current_uiout->redirect (NULL);
1015   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
1016   result = gdbscm_scm_from_c_string (buf.c_str ());
1017
1018   return result;
1019 }
1020
1021 /* (breakpoint-type <gdb:breakpoint>) -> integer */
1022
1023 static SCM
1024 gdbscm_breakpoint_type (SCM self)
1025 {
1026   breakpoint_smob *bp_smob
1027     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1028
1029   return scm_from_long (bp_smob->bp->type);
1030 }
1031
1032 /* (breakpoint-visible? <gdb:breakpoint>) -> boolean */
1033
1034 static SCM
1035 gdbscm_breakpoint_visible (SCM self)
1036 {
1037   breakpoint_smob *bp_smob
1038     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1039
1040   return scm_from_bool (bp_smob->bp->number >= 0);
1041 }
1042
1043 /* (breakpoint-number <gdb:breakpoint>) -> integer */
1044
1045 static SCM
1046 gdbscm_breakpoint_number (SCM self)
1047 {
1048   breakpoint_smob *bp_smob
1049     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1050
1051   return scm_from_long (bp_smob->number);
1052 }
1053
1054 /* (breakpoint-temporary? <gdb:breakpoint>) -> boolean */
1055
1056 static SCM
1057 gdbscm_breakpoint_temporary (SCM self)
1058 {
1059   breakpoint_smob *bp_smob
1060     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1061
1062   return scm_from_bool (bp_smob->bp->disposition == disp_del
1063                         || bp_smob->bp->disposition == disp_del_at_next_stop);
1064 }
1065 \f
1066 /* Return TRUE if "stop" has been set for this breakpoint.
1067
1068    This is the extension_language_ops.breakpoint_has_cond "method".  */
1069
1070 int
1071 gdbscm_breakpoint_has_cond (const struct extension_language_defn *extlang,
1072                             struct breakpoint *b)
1073 {
1074   breakpoint_smob *bp_smob = b->scm_bp_object;
1075
1076   if (bp_smob == NULL)
1077     return 0;
1078
1079   return gdbscm_is_procedure (bp_smob->stop);
1080 }
1081
1082 /* Call the "stop" method in the breakpoint class.
1083    This must only be called if gdbscm_breakpoint_has_cond returns true.
1084    If the stop method returns #t, the inferior will be stopped at the
1085    breakpoint.  Otherwise the inferior will be allowed to continue
1086    (assuming other conditions don't indicate "stop").
1087
1088    This is the extension_language_ops.breakpoint_cond_says_stop "method".  */
1089
1090 enum ext_lang_bp_stop
1091 gdbscm_breakpoint_cond_says_stop
1092   (const struct extension_language_defn *extlang, struct breakpoint *b)
1093 {
1094   breakpoint_smob *bp_smob = b->scm_bp_object;
1095   SCM predicate_result;
1096   int stop;
1097
1098   if (bp_smob == NULL)
1099     return EXT_LANG_BP_STOP_UNSET;
1100   if (!gdbscm_is_procedure (bp_smob->stop))
1101     return EXT_LANG_BP_STOP_UNSET;
1102
1103   stop = 1;
1104
1105   predicate_result
1106     = gdbscm_safe_call_1 (bp_smob->stop, bp_smob->containing_scm, NULL);
1107
1108   if (gdbscm_is_exception (predicate_result))
1109     ; /* Exception already printed.  */
1110   /* If the "stop" function returns #f that means
1111      the Scheme breakpoint wants GDB to continue.  */
1112   else if (gdbscm_is_false (predicate_result))
1113     stop = 0;
1114
1115   return stop ? EXT_LANG_BP_STOP_YES : EXT_LANG_BP_STOP_NO;
1116 }
1117 \f
1118 /* Event callback functions.  */
1119
1120 /* Callback that is used when a breakpoint is created.
1121    For breakpoints created by Scheme, i.e., gdbscm_create_breakpoint_x, finish
1122    object creation by connecting the Scheme wrapper to the gdb object.
1123    We ignore breakpoints created from gdb or python here, we create the
1124    Scheme wrapper for those when there's a need to, e.g.,
1125    gdbscm_breakpoints.  */
1126
1127 static void
1128 bpscm_breakpoint_created (struct breakpoint *bp)
1129 {
1130   SCM bp_scm;
1131
1132   if (gdbscm_is_false (pending_breakpoint_scm))
1133     return;
1134
1135   /* Verify our caller error checked the user's request.  */
1136   gdb_assert (bpscm_want_scm_wrapper_p (bp, 1));
1137
1138   bp_scm = pending_breakpoint_scm;
1139   pending_breakpoint_scm = SCM_BOOL_F;
1140
1141   bpscm_attach_scm_to_breakpoint (bp, bp_scm);
1142 }
1143
1144 /* Callback that is used when a breakpoint is deleted.  This will
1145    invalidate the corresponding Scheme object.  */
1146
1147 static void
1148 bpscm_breakpoint_deleted (struct breakpoint *b)
1149 {
1150   int num = b->number;
1151   struct breakpoint *bp;
1152
1153   /* TODO: Why the lookup?  We have B.  */
1154
1155   bp = get_breakpoint (num);
1156   if (bp)
1157     {
1158       breakpoint_smob *bp_smob = bp->scm_bp_object;
1159
1160       if (bp_smob)
1161         {
1162           bp_smob->bp = NULL;
1163           bp_smob->number = -1;
1164           bp_smob->stop = SCM_BOOL_F;
1165           scm_gc_unprotect_object (bp_smob->containing_scm);
1166         }
1167     }
1168 }
1169 \f
1170 /* Initialize the Scheme breakpoint code.  */
1171
1172 static const scheme_integer_constant breakpoint_integer_constants[] =
1173 {
1174   { "BP_NONE", bp_none },
1175   { "BP_BREAKPOINT", bp_breakpoint },
1176   { "BP_WATCHPOINT", bp_watchpoint },
1177   { "BP_HARDWARE_WATCHPOINT", bp_hardware_watchpoint },
1178   { "BP_READ_WATCHPOINT", bp_read_watchpoint },
1179   { "BP_ACCESS_WATCHPOINT", bp_access_watchpoint },
1180   { "BP_CATCHPOINT", bp_catchpoint },
1181
1182   { "WP_READ", hw_read },
1183   { "WP_WRITE", hw_write },
1184   { "WP_ACCESS", hw_access },
1185
1186   END_INTEGER_CONSTANTS
1187 };
1188
1189 static const scheme_function breakpoint_functions[] =
1190 {
1191   { "make-breakpoint", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_breakpoint),
1192     "\
1193 Create a GDB breakpoint object.\n\
1194 \n\
1195   Arguments:\n\
1196     location [#:type <type>] [#:wp-class <wp-class>] [#:internal <bool>] [#:temporary <bool>]\n\
1197   Returns:\n\
1198     <gdb:breakpoint> object" },
1199
1200   { "register-breakpoint!", 1, 0, 0,
1201     as_a_scm_t_subr (gdbscm_register_breakpoint_x),
1202     "\
1203 Register a <gdb:breakpoint> object with GDB." },
1204
1205   { "delete-breakpoint!", 1, 0, 0, as_a_scm_t_subr (gdbscm_delete_breakpoint_x),
1206     "\
1207 Delete the breakpoint from GDB." },
1208
1209   { "breakpoints", 0, 0, 0, as_a_scm_t_subr (gdbscm_breakpoints),
1210     "\
1211 Return a list of all GDB breakpoints.\n\
1212 \n\
1213   Arguments: none" },
1214
1215   { "breakpoint?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_p),
1216     "\
1217 Return #t if the object is a <gdb:breakpoint> object." },
1218
1219   { "breakpoint-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_valid_p),
1220     "\
1221 Return #t if the breakpoint has not been deleted from GDB." },
1222
1223   { "breakpoint-number", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_number),
1224     "\
1225 Return the breakpoint's number." },
1226
1227   { "breakpoint-temporary?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_temporary),
1228     "\
1229 Return #t if the breakpoint is a temporary breakpoint." },
1230
1231   { "breakpoint-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_type),
1232     "\
1233 Return the type of the breakpoint." },
1234
1235   { "breakpoint-visible?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_visible),
1236     "\
1237 Return #t if the breakpoint is visible to the user." },
1238
1239   { "breakpoint-location", 1, 0, 0,
1240     as_a_scm_t_subr (gdbscm_breakpoint_location),
1241     "\
1242 Return the location of the breakpoint as specified by the user." },
1243
1244   { "breakpoint-expression", 1, 0, 0,
1245     as_a_scm_t_subr (gdbscm_breakpoint_expression),
1246     "\
1247 Return the expression of the breakpoint as specified by the user.\n\
1248 Valid for watchpoints only, returns #f for non-watchpoints." },
1249
1250   { "breakpoint-enabled?", 1, 0, 0,
1251     as_a_scm_t_subr (gdbscm_breakpoint_enabled_p),
1252     "\
1253 Return #t if the breakpoint is enabled." },
1254
1255   { "set-breakpoint-enabled!", 2, 0, 0,
1256     as_a_scm_t_subr (gdbscm_set_breakpoint_enabled_x),
1257     "\
1258 Set the breakpoint's enabled state.\n\
1259 \n\
1260   Arguments: <gdb:breakpoint> boolean" },
1261
1262   { "breakpoint-silent?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_silent_p),
1263     "\
1264 Return #t if the breakpoint is silent." },
1265
1266   { "set-breakpoint-silent!", 2, 0, 0,
1267     as_a_scm_t_subr (gdbscm_set_breakpoint_silent_x),
1268     "\
1269 Set the breakpoint's silent state.\n\
1270 \n\
1271   Arguments: <gdb:breakpoint> boolean" },
1272
1273   { "breakpoint-ignore-count", 1, 0, 0,
1274     as_a_scm_t_subr (gdbscm_breakpoint_ignore_count),
1275     "\
1276 Return the breakpoint's \"ignore\" count." },
1277
1278   { "set-breakpoint-ignore-count!", 2, 0, 0,
1279     as_a_scm_t_subr (gdbscm_set_breakpoint_ignore_count_x),
1280     "\
1281 Set the breakpoint's \"ignore\" count.\n\
1282 \n\
1283   Arguments: <gdb:breakpoint> count" },
1284
1285   { "breakpoint-hit-count", 1, 0, 0,
1286     as_a_scm_t_subr (gdbscm_breakpoint_hit_count),
1287     "\
1288 Return the breakpoint's \"hit\" count." },
1289
1290   { "set-breakpoint-hit-count!", 2, 0, 0,
1291     as_a_scm_t_subr (gdbscm_set_breakpoint_hit_count_x),
1292     "\
1293 Set the breakpoint's \"hit\" count.  The value must be zero.\n\
1294 \n\
1295   Arguments: <gdb:breakpoint> 0" },
1296
1297   { "breakpoint-thread", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_thread),
1298     "\
1299 Return the breakpoint's global thread id or #f if there isn't one." },
1300
1301   { "set-breakpoint-thread!", 2, 0, 0,
1302     as_a_scm_t_subr (gdbscm_set_breakpoint_thread_x),
1303     "\
1304 Set the global thread id for this breakpoint.\n\
1305 \n\
1306   Arguments: <gdb:breakpoint> global-thread-id" },
1307
1308   { "breakpoint-task", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_task),
1309     "\
1310 Return the breakpoint's Ada task-id or #f if there isn't one." },
1311
1312   { "set-breakpoint-task!", 2, 0, 0,
1313     as_a_scm_t_subr (gdbscm_set_breakpoint_task_x),
1314     "\
1315 Set the breakpoint's Ada task-id.\n\
1316 \n\
1317   Arguments: <gdb:breakpoint> task-id" },
1318
1319   { "breakpoint-condition", 1, 0, 0,
1320     as_a_scm_t_subr (gdbscm_breakpoint_condition),
1321     "\
1322 Return the breakpoint's condition as specified by the user.\n\
1323 Return #f if there isn't one." },
1324
1325   { "set-breakpoint-condition!", 2, 0, 0,
1326     as_a_scm_t_subr (gdbscm_set_breakpoint_condition_x),
1327     "\
1328 Set the breakpoint's condition.\n\
1329 \n\
1330   Arguments: <gdb:breakpoint> condition\n\
1331     condition: a string" },
1332
1333   { "breakpoint-stop", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_stop),
1334     "\
1335 Return the breakpoint's stop predicate.\n\
1336 Return #f if there isn't one." },
1337
1338   { "set-breakpoint-stop!", 2, 0, 0,
1339     as_a_scm_t_subr (gdbscm_set_breakpoint_stop_x),
1340     "\
1341 Set the breakpoint's stop predicate.\n\
1342 \n\
1343   Arguments: <gdb:breakpoint> procedure\n\
1344     procedure: A procedure of one argument, the breakpoint.\n\
1345       Its result is true if program execution should stop." },
1346
1347   { "breakpoint-commands", 1, 0, 0,
1348     as_a_scm_t_subr (gdbscm_breakpoint_commands),
1349     "\
1350 Return the breakpoint's commands." },
1351
1352   END_FUNCTIONS
1353 };
1354
1355 void
1356 gdbscm_initialize_breakpoints (void)
1357 {
1358   breakpoint_smob_tag
1359     = gdbscm_make_smob_type (breakpoint_smob_name, sizeof (breakpoint_smob));
1360   scm_set_smob_free (breakpoint_smob_tag, bpscm_free_breakpoint_smob);
1361   scm_set_smob_print (breakpoint_smob_tag, bpscm_print_breakpoint_smob);
1362
1363   gdb::observers::breakpoint_created.attach (bpscm_breakpoint_created,
1364                                              "scm-breakpoint");
1365   gdb::observers::breakpoint_deleted.attach (bpscm_breakpoint_deleted,
1366                                              "scm-breakpoint");
1367
1368   gdbscm_define_integer_constants (breakpoint_integer_constants, 1);
1369   gdbscm_define_functions (breakpoint_functions, 1);
1370
1371   type_keyword = scm_from_latin1_keyword ("type");
1372   wp_class_keyword = scm_from_latin1_keyword ("wp-class");
1373   internal_keyword = scm_from_latin1_keyword ("internal");
1374   temporary_keyword = scm_from_latin1_keyword ("temporary");
1375 }