gdb/guile/scm-breakpoint.c

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