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 bool
 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   return false;
 540 }
 541
 542 /* (breakpoints) -> list
 543    Return a list of all breakpoints.  */
 544
 545 static SCM
 546 gdbscm_breakpoints (void)
 547 {
 548   SCM list = SCM_EOL;
 549
 550   iterate_over_breakpoints ([&] (breakpoint *bp)
 551     {
 552       return bpscm_build_bp_list(bp, &list);
 553     });
 554
 555   return scm_reverse_x (list, SCM_EOL);
 556 }
 557
 558 /* (breakpoint-valid? <gdb:breakpoint>) -> boolean
 559    Returns #t if SELF is still valid.  */
 560
 561 static SCM
 562 gdbscm_breakpoint_valid_p (SCM self)
 563 {
 564   breakpoint_smob *bp_smob
 565     = bpscm_get_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 566
 567   return scm_from_bool (bpscm_is_valid (bp_smob));
 568 }
 569
 570 /* (breakpoint-enabled? <gdb:breakpoint>) -> boolean */
 571
 572 static SCM
 573 gdbscm_breakpoint_enabled_p (SCM self)
 574 {
 575   breakpoint_smob *bp_smob
 576     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 577
 578   return scm_from_bool (bp_smob->bp->enable_state == bp_enabled);
 579 }
 580
 581 /* (set-breakpoint-enabled? <gdb:breakpoint> boolean) -> unspecified */
 582
 583 static SCM
 584 gdbscm_set_breakpoint_enabled_x (SCM self, SCM newvalue)
 585 {
 586   breakpoint_smob *bp_smob
 587     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 588
 589   SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME,
 590                    _("boolean"));
 591
 592   gdbscm_gdb_exception exc {};
 593   try
 594     {
 595       if (gdbscm_is_true (newvalue))
 596         enable_breakpoint (bp_smob->bp);
 597       else
 598         disable_breakpoint (bp_smob->bp);
 599     }
 600   catch (const gdb_exception &except)
 601     {
 602       exc = unpack (except);
 603     }
 604
 605   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 606   return SCM_UNSPECIFIED;
 607 }
 608
 609 /* (breakpoint-silent? <gdb:breakpoint>) -> boolean */
 610
 611 static SCM
 612 gdbscm_breakpoint_silent_p (SCM self)
 613 {
 614   breakpoint_smob *bp_smob
 615     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 616
 617   return scm_from_bool (bp_smob->bp->silent);
 618 }
 619
 620 /* (set-breakpoint-silent?! <gdb:breakpoint> boolean) -> unspecified */
 621
 622 static SCM
 623 gdbscm_set_breakpoint_silent_x (SCM self, SCM newvalue)
 624 {
 625   breakpoint_smob *bp_smob
 626     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 627
 628   SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME,
 629                    _("boolean"));
 630
 631   gdbscm_gdb_exception exc {};
 632   try
 633     {
 634       breakpoint_set_silent (bp_smob->bp, gdbscm_is_true (newvalue));
 635     }
 636   catch (const gdb_exception &except)
 637     {
 638       exc = unpack (except);
 639     }
 640
 641   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 642   return SCM_UNSPECIFIED;
 643 }
 644
 645 /* (breakpoint-ignore-count <gdb:breakpoint>) -> integer */
 646
 647 static SCM
 648 gdbscm_breakpoint_ignore_count (SCM self)
 649 {
 650   breakpoint_smob *bp_smob
 651     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 652
 653   return scm_from_long (bp_smob->bp->ignore_count);
 654 }
 655
 656 /* (set-breakpoint-ignore-count! <gdb:breakpoint> integer)
 657      -> unspecified */
 658
 659 static SCM
 660 gdbscm_set_breakpoint_ignore_count_x (SCM self, SCM newvalue)
 661 {
 662   breakpoint_smob *bp_smob
 663     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 664   long value;
 665
 666   SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX),
 667                    newvalue, SCM_ARG2, FUNC_NAME, _("integer"));
 668
 669   value = scm_to_long (newvalue);
 670   if (value < 0)
 671     value = 0;
 672
 673   gdbscm_gdb_exception exc {};
 674   try
 675     {
 676       set_ignore_count (bp_smob->number, (int) value, 0);
 677     }
 678   catch (const gdb_exception &except)
 679     {
 680       exc = unpack (except);
 681     }
 682
 683   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 684   return SCM_UNSPECIFIED;
 685 }
 686
 687 /* (breakpoint-hit-count <gdb:breakpoint>) -> integer */
 688
 689 static SCM
 690 gdbscm_breakpoint_hit_count (SCM self)
 691 {
 692   breakpoint_smob *bp_smob
 693     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 694
 695   return scm_from_long (bp_smob->bp->hit_count);
 696 }
 697
 698 /* (set-breakpoint-hit-count! <gdb:breakpoint> integer) -> unspecified */
 699
 700 static SCM
 701 gdbscm_set_breakpoint_hit_count_x (SCM self, SCM newvalue)
 702 {
 703   breakpoint_smob *bp_smob
 704     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 705   long value;
 706
 707   SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX),
 708                    newvalue, SCM_ARG2, FUNC_NAME, _("integer"));
 709
 710   value = scm_to_long (newvalue);
 711   if (value < 0)
 712     value = 0;
 713
 714   if (value != 0)
 715     {
 716       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 717                                  _("hit-count must be zero"));
 718     }
 719
 720   bp_smob->bp->hit_count = 0;
 721
 722   return SCM_UNSPECIFIED;
 723 }
 724
 725 /* (breakpoint-thread <gdb:breakpoint>) -> integer */
 726
 727 static SCM
 728 gdbscm_breakpoint_thread (SCM self)
 729 {
 730   breakpoint_smob *bp_smob
 731     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 732
 733   if (bp_smob->bp->thread == -1)
 734     return SCM_BOOL_F;
 735
 736   return scm_from_long (bp_smob->bp->thread);
 737 }
 738
 739 /* (set-breakpoint-thread! <gdb:breakpoint> integer) -> unspecified */
 740
 741 static SCM
 742 gdbscm_set_breakpoint_thread_x (SCM self, SCM newvalue)
 743 {
 744   breakpoint_smob *bp_smob
 745     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 746   long id;
 747
 748   if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
 749     {
 750       id = scm_to_long (newvalue);
 751       if (!valid_global_thread_id (id))
 752         {
 753           gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 754                                      _("invalid thread id"));
 755         }
 756     }
 757   else if (gdbscm_is_false (newvalue))
 758     id = -1;
 759   else
 760     SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f"));
 761
 762   breakpoint_set_thread (bp_smob->bp, id);
 763
 764   return SCM_UNSPECIFIED;
 765 }
 766
 767 /* (breakpoint-task <gdb:breakpoint>) -> integer */
 768
 769 static SCM
 770 gdbscm_breakpoint_task (SCM self)
 771 {
 772   breakpoint_smob *bp_smob
 773     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 774
 775   if (bp_smob->bp->task == 0)
 776     return SCM_BOOL_F;
 777
 778   return scm_from_long (bp_smob->bp->task);
 779 }
 780
 781 /* (set-breakpoint-task! <gdb:breakpoint> integer) -> unspecified */
 782
 783 static SCM
 784 gdbscm_set_breakpoint_task_x (SCM self, SCM newvalue)
 785 {
 786   breakpoint_smob *bp_smob
 787     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 788   long id;
 789   int valid_id = 0;
 790
 791   if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
 792     {
 793       id = scm_to_long (newvalue);
 794
 795       gdbscm_gdb_exception exc {};
 796       try
 797         {
 798           valid_id = valid_task_id (id);
 799         }
 800       catch (const gdb_exception &except)
 801         {
 802           exc = unpack (except);
 803         }
 804
 805       GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 806       if (! valid_id)
 807         {
 808           gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 809                                      _("invalid task id"));
 810         }
 811     }
 812   else if (gdbscm_is_false (newvalue))
 813     id = 0;
 814   else
 815     SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f"));
 816
 817   gdbscm_gdb_exception exc {};
 818   try
 819     {
 820       breakpoint_set_task (bp_smob->bp, id);
 821     }
 822   catch (const gdb_exception &except)
 823     {
 824       exc = unpack (except);
 825     }
 826
 827   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 828   return SCM_UNSPECIFIED;
 829 }
 830
 831 /* (breakpoint-location <gdb:breakpoint>) -> string */
 832
 833 static SCM
 834 gdbscm_breakpoint_location (SCM self)
 835 {
 836   breakpoint_smob *bp_smob
 837     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 838   const char *str;
 839
 840   if (bp_smob->bp->type != bp_breakpoint)
 841     return SCM_BOOL_F;
 842
 843   str = event_location_to_string (bp_smob->bp->location.get ());
 844   if (! str)
 845     str = "";
 846
 847   return gdbscm_scm_from_c_string (str);
 848 }
 849
 850 /* (breakpoint-expression <gdb:breakpoint>) -> string
 851    This is only valid for watchpoints.
 852    Returns #f for non-watchpoints.  */
 853
 854 static SCM
 855 gdbscm_breakpoint_expression (SCM self)
 856 {
 857   breakpoint_smob *bp_smob
 858     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 859   struct watchpoint *wp;
 860
 861   if (!is_watchpoint (bp_smob->bp))
 862     return SCM_BOOL_F;
 863
 864   wp = (struct watchpoint *) bp_smob->bp;
 865
 866   const char *str = wp->exp_string;
 867   if (! str)
 868     str = "";
 869
 870   return gdbscm_scm_from_c_string (str);
 871 }
 872
 873 /* (breakpoint-condition <gdb:breakpoint>) -> string */
 874
 875 static SCM
 876 gdbscm_breakpoint_condition (SCM self)
 877 {
 878   breakpoint_smob *bp_smob
 879     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 880   char *str;
 881
 882   str = bp_smob->bp->cond_string;
 883   if (! str)
 884     return SCM_BOOL_F;
 885
 886   return gdbscm_scm_from_c_string (str);
 887 }
 888
 889 /* (set-breakpoint-condition! <gdb:breakpoint> string|#f)
 890    -> unspecified */
 891
 892 static SCM
 893 gdbscm_set_breakpoint_condition_x (SCM self, SCM newvalue)
 894 {
 895   breakpoint_smob *bp_smob
 896     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 897
 898   SCM_ASSERT_TYPE (scm_is_string (newvalue) || gdbscm_is_false (newvalue),
 899                    newvalue, SCM_ARG2, FUNC_NAME,
 900                    _("string or #f"));
 901
 902   return gdbscm_wrap ([=]
 903     {
 904       gdb::unique_xmalloc_ptr<char> exp
 905         = (gdbscm_is_false (newvalue)
 906            ? nullptr
 907            : gdbscm_scm_to_c_string (newvalue));
 908
 909       set_breakpoint_condition (bp_smob->bp, exp ? exp.get () : "", 0, false);
 910
 911       return SCM_UNSPECIFIED;
 912     });
 913 }
 914
 915 /* (breakpoint-stop <gdb:breakpoint>) -> procedure or #f */
 916
 917 static SCM
 918 gdbscm_breakpoint_stop (SCM self)
 919 {
 920   breakpoint_smob *bp_smob
 921     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 922
 923   return bp_smob->stop;
 924 }
 925
 926 /* (set-breakpoint-stop! <gdb:breakpoint> procedure|#f)
 927    -> unspecified */
 928
 929 static SCM
 930 gdbscm_set_breakpoint_stop_x (SCM self, SCM newvalue)
 931 {
 932   breakpoint_smob *bp_smob
 933     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 934   const struct extension_language_defn *extlang = NULL;
 935
 936   SCM_ASSERT_TYPE (gdbscm_is_procedure (newvalue)
 937                    || gdbscm_is_false (newvalue),
 938                    newvalue, SCM_ARG2, FUNC_NAME,
 939                    _("procedure or #f"));
 940
 941   if (bp_smob->bp->cond_string != NULL)
 942     extlang = get_ext_lang_defn (EXT_LANG_GDB);
 943   if (extlang == NULL)
 944     extlang = get_breakpoint_cond_ext_lang (bp_smob->bp, EXT_LANG_GUILE);
 945   if (extlang != NULL)
 946     {
 947       char *error_text
 948         = xstrprintf (_("Only one stop condition allowed.  There is"
 949                         " currently a %s stop condition defined for"
 950                         " this breakpoint."),
 951                       ext_lang_capitalized_name (extlang));
 952
 953       scm_dynwind_begin ((scm_t_dynwind_flags) 0);
 954       gdbscm_dynwind_xfree (error_text);
 955       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self, error_text);
 956       /* The following line, while unnecessary, is present for completeness
 957          sake.  */
 958       scm_dynwind_end ();
 959     }
 960
 961   bp_smob->stop = newvalue;
 962
 963   return SCM_UNSPECIFIED;
 964 }
 965
 966 /* (breakpoint-commands <gdb:breakpoint>) -> string */
 967
 968 static SCM
 969 gdbscm_breakpoint_commands (SCM self)
 970 {
 971   breakpoint_smob *bp_smob
 972     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 973   struct breakpoint *bp;
 974   SCM result;
 975
 976   bp = bp_smob->bp;
 977
 978   if (bp->commands == NULL)
 979     return SCM_BOOL_F;
 980
 981   string_file buf;
 982
 983   current_uiout->redirect (&buf);
 984   gdbscm_gdb_exception exc {};
 985   try
 986     {
 987       print_command_lines (current_uiout, breakpoint_commands (bp), 0);
 988     }
 989   catch (const gdb_exception &except)
 990     {
 991       exc = unpack (except);
 992     }
 993
 994   current_uiout->redirect (NULL);
 995   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 996   result = gdbscm_scm_from_c_string (buf.c_str ());
 997
 998   return result;
 999 }
1000
1001 /* (breakpoint-type <gdb:breakpoint>) -> integer */
1002
1003 static SCM
1004 gdbscm_breakpoint_type (SCM self)
1005 {
1006   breakpoint_smob *bp_smob
1007     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1008
1009   return scm_from_long (bp_smob->bp->type);
1010 }
1011
1012 /* (breakpoint-visible? <gdb:breakpoint>) -> boolean */
1013
1014 static SCM
1015 gdbscm_breakpoint_visible (SCM self)
1016 {
1017   breakpoint_smob *bp_smob
1018     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1019
1020   return scm_from_bool (bp_smob->bp->number >= 0);
1021 }
1022
1023 /* (breakpoint-number <gdb:breakpoint>) -> integer */
1024
1025 static SCM
1026 gdbscm_breakpoint_number (SCM self)
1027 {
1028   breakpoint_smob *bp_smob
1029     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1030
1031   return scm_from_long (bp_smob->number);
1032 }
1033 \f
1034 /* Return TRUE if "stop" has been set for this breakpoint.
1035
1036    This is the extension_language_ops.breakpoint_has_cond "method".  */
1037
1038 int
1039 gdbscm_breakpoint_has_cond (const struct extension_language_defn *extlang,
1040                             struct breakpoint *b)
1041 {
1042   breakpoint_smob *bp_smob = b->scm_bp_object;
1043
1044   if (bp_smob == NULL)
1045     return 0;
1046
1047   return gdbscm_is_procedure (bp_smob->stop);
1048 }
1049
1050 /* Call the "stop" method in the breakpoint class.
1051    This must only be called if gdbscm_breakpoint_has_cond returns true.
1052    If the stop method returns #t, the inferior will be stopped at the
1053    breakpoint.  Otherwise the inferior will be allowed to continue
1054    (assuming other conditions don't indicate "stop").
1055
1056    This is the extension_language_ops.breakpoint_cond_says_stop "method".  */
1057
1058 enum ext_lang_bp_stop
1059 gdbscm_breakpoint_cond_says_stop
1060   (const struct extension_language_defn *extlang, struct breakpoint *b)
1061 {
1062   breakpoint_smob *bp_smob = b->scm_bp_object;
1063   SCM predicate_result;
1064   int stop;
1065
1066   if (bp_smob == NULL)
1067     return EXT_LANG_BP_STOP_UNSET;
1068   if (!gdbscm_is_procedure (bp_smob->stop))
1069     return EXT_LANG_BP_STOP_UNSET;
1070
1071   stop = 1;
1072
1073   predicate_result
1074     = gdbscm_safe_call_1 (bp_smob->stop, bp_smob->containing_scm, NULL);
1075
1076   if (gdbscm_is_exception (predicate_result))
1077     ; /* Exception already printed.  */
1078   /* If the "stop" function returns #f that means
1079      the Scheme breakpoint wants GDB to continue.  */
1080   else if (gdbscm_is_false (predicate_result))
1081     stop = 0;
1082
1083   return stop ? EXT_LANG_BP_STOP_YES : EXT_LANG_BP_STOP_NO;
1084 }
1085 \f
1086 /* Event callback functions.  */
1087
1088 /* Callback that is used when a breakpoint is created.
1089    For breakpoints created by Scheme, i.e., gdbscm_create_breakpoint_x, finish
1090    object creation by connecting the Scheme wrapper to the gdb object.
1091    We ignore breakpoints created from gdb or python here, we create the
1092    Scheme wrapper for those when there's a need to, e.g.,
1093    gdbscm_breakpoints.  */
1094
1095 static void
1096 bpscm_breakpoint_created (struct breakpoint *bp)
1097 {
1098   SCM bp_scm;
1099
1100   if (gdbscm_is_false (pending_breakpoint_scm))
1101     return;
1102
1103   /* Verify our caller error checked the user's request.  */
1104   gdb_assert (bpscm_want_scm_wrapper_p (bp, 1));
1105
1106   bp_scm = pending_breakpoint_scm;
1107   pending_breakpoint_scm = SCM_BOOL_F;
1108
1109   bpscm_attach_scm_to_breakpoint (bp, bp_scm);
1110 }
1111
1112 /* Callback that is used when a breakpoint is deleted.  This will
1113    invalidate the corresponding Scheme object.  */
1114
1115 static void
1116 bpscm_breakpoint_deleted (struct breakpoint *b)
1117 {
1118   int num = b->number;
1119   struct breakpoint *bp;
1120
1121   /* TODO: Why the lookup?  We have B.  */
1122
1123   bp = get_breakpoint (num);
1124   if (bp)
1125     {
1126       breakpoint_smob *bp_smob = bp->scm_bp_object;
1127
1128       if (bp_smob)
1129         {
1130           bp_smob->bp = NULL;
1131           bp_smob->number = -1;
1132           bp_smob->stop = SCM_BOOL_F;
1133           scm_gc_unprotect_object (bp_smob->containing_scm);
1134         }
1135     }
1136 }
1137 \f
1138 /* Initialize the Scheme breakpoint code.  */
1139
1140 static const scheme_integer_constant breakpoint_integer_constants[] =
1141 {
1142   { "BP_NONE", bp_none },
1143   { "BP_BREAKPOINT", bp_breakpoint },
1144   { "BP_WATCHPOINT", bp_watchpoint },
1145   { "BP_HARDWARE_WATCHPOINT", bp_hardware_watchpoint },
1146   { "BP_READ_WATCHPOINT", bp_read_watchpoint },
1147   { "BP_ACCESS_WATCHPOINT", bp_access_watchpoint },
1148
1149   { "WP_READ", hw_read },
1150   { "WP_WRITE", hw_write },
1151   { "WP_ACCESS", hw_access },
1152
1153   END_INTEGER_CONSTANTS
1154 };
1155
1156 static const scheme_function breakpoint_functions[] =
1157 {
1158   { "make-breakpoint", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_breakpoint),
1159     "\
1160 Create a GDB breakpoint object.\n\
1161 \n\
1162   Arguments:\n\
1163     location [#:type <type>] [#:wp-class <wp-class>] [#:internal <bool>]\n\
1164   Returns:\n\
1165     <gdb:breakpoint object" },
1166
1167   { "register-breakpoint!", 1, 0, 0,
1168     as_a_scm_t_subr (gdbscm_register_breakpoint_x),
1169     "\
1170 Register a <gdb:breakpoint> object with GDB." },
1171
1172   { "delete-breakpoint!", 1, 0, 0, as_a_scm_t_subr (gdbscm_delete_breakpoint_x),
1173     "\
1174 Delete the breakpoint from GDB." },
1175
1176   { "breakpoints", 0, 0, 0, as_a_scm_t_subr (gdbscm_breakpoints),
1177     "\
1178 Return a list of all GDB breakpoints.\n\
1179 \n\
1180   Arguments: none" },
1181
1182   { "breakpoint?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_p),
1183     "\
1184 Return #t if the object is a <gdb:breakpoint> object." },
1185
1186   { "breakpoint-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_valid_p),
1187     "\
1188 Return #t if the breakpoint has not been deleted from GDB." },
1189
1190   { "breakpoint-number", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_number),
1191     "\
1192 Return the breakpoint's number." },
1193
1194   { "breakpoint-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_type),
1195     "\
1196 Return the type of the breakpoint." },
1197
1198   { "breakpoint-visible?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_visible),
1199     "\
1200 Return #t if the breakpoint is visible to the user." },
1201
1202   { "breakpoint-location", 1, 0, 0,
1203     as_a_scm_t_subr (gdbscm_breakpoint_location),
1204     "\
1205 Return the location of the breakpoint as specified by the user." },
1206
1207   { "breakpoint-expression", 1, 0, 0,
1208     as_a_scm_t_subr (gdbscm_breakpoint_expression),
1209     "\
1210 Return the expression of the breakpoint as specified by the user.\n\
1211 Valid for watchpoints only, returns #f for non-watchpoints." },
1212
1213   { "breakpoint-enabled?", 1, 0, 0,
1214     as_a_scm_t_subr (gdbscm_breakpoint_enabled_p),
1215     "\
1216 Return #t if the breakpoint is enabled." },
1217
1218   { "set-breakpoint-enabled!", 2, 0, 0,
1219     as_a_scm_t_subr (gdbscm_set_breakpoint_enabled_x),
1220     "\
1221 Set the breakpoint's enabled state.\n\
1222 \n\
1223   Arguments: <gdb:breakpoint> boolean" },
1224
1225   { "breakpoint-silent?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_silent_p),
1226     "\
1227 Return #t if the breakpoint is silent." },
1228
1229   { "set-breakpoint-silent!", 2, 0, 0,
1230     as_a_scm_t_subr (gdbscm_set_breakpoint_silent_x),
1231     "\
1232 Set the breakpoint's silent state.\n\
1233 \n\
1234   Arguments: <gdb:breakpoint> boolean" },
1235
1236   { "breakpoint-ignore-count", 1, 0, 0,
1237     as_a_scm_t_subr (gdbscm_breakpoint_ignore_count),
1238     "\
1239 Return the breakpoint's \"ignore\" count." },
1240
1241   { "set-breakpoint-ignore-count!", 2, 0, 0,
1242     as_a_scm_t_subr (gdbscm_set_breakpoint_ignore_count_x),
1243     "\
1244 Set the breakpoint's \"ignore\" count.\n\
1245 \n\
1246   Arguments: <gdb:breakpoint> count" },
1247
1248   { "breakpoint-hit-count", 1, 0, 0,
1249     as_a_scm_t_subr (gdbscm_breakpoint_hit_count),
1250     "\
1251 Return the breakpoint's \"hit\" count." },
1252
1253   { "set-breakpoint-hit-count!", 2, 0, 0,
1254     as_a_scm_t_subr (gdbscm_set_breakpoint_hit_count_x),
1255     "\
1256 Set the breakpoint's \"hit\" count.  The value must be zero.\n\
1257 \n\
1258   Arguments: <gdb:breakpoint> 0" },
1259
1260   { "breakpoint-thread", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_thread),
1261     "\
1262 Return the breakpoint's global thread id or #f if there isn't one." },
1263
1264   { "set-breakpoint-thread!", 2, 0, 0,
1265     as_a_scm_t_subr (gdbscm_set_breakpoint_thread_x),
1266     "\
1267 Set the global thread id for this breakpoint.\n\
1268 \n\
1269   Arguments: <gdb:breakpoint> global-thread-id" },
1270
1271   { "breakpoint-task", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_task),
1272     "\
1273 Return the breakpoint's Ada task-id or #f if there isn't one." },
1274
1275   { "set-breakpoint-task!", 2, 0, 0,
1276     as_a_scm_t_subr (gdbscm_set_breakpoint_task_x),
1277     "\
1278 Set the breakpoint's Ada task-id.\n\
1279 \n\
1280   Arguments: <gdb:breakpoint> task-id" },
1281
1282   { "breakpoint-condition", 1, 0, 0,
1283     as_a_scm_t_subr (gdbscm_breakpoint_condition),
1284     "\
1285 Return the breakpoint's condition as specified by the user.\n\
1286 Return #f if there isn't one." },
1287
1288   { "set-breakpoint-condition!", 2, 0, 0,
1289     as_a_scm_t_subr (gdbscm_set_breakpoint_condition_x),
1290     "\
1291 Set the breakpoint's condition.\n\
1292 \n\
1293   Arguments: <gdb:breakpoint> condition\n\
1294     condition: a string" },
1295
1296   { "breakpoint-stop", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_stop),
1297     "\
1298 Return the breakpoint's stop predicate.\n\
1299 Return #f if there isn't one." },
1300
1301   { "set-breakpoint-stop!", 2, 0, 0,
1302     as_a_scm_t_subr (gdbscm_set_breakpoint_stop_x),
1303     "\
1304 Set the breakpoint's stop predicate.\n\
1305 \n\
1306   Arguments: <gdb:breakpoint> procedure\n\
1307     procedure: A procedure of one argument, the breakpoint.\n\
1308       Its result is true if program execution should stop." },
1309
1310   { "breakpoint-commands", 1, 0, 0,
1311     as_a_scm_t_subr (gdbscm_breakpoint_commands),
1312     "\
1313 Return the breakpoint's commands." },
1314
1315   END_FUNCTIONS
1316 };
1317
1318 void
1319 gdbscm_initialize_breakpoints (void)
1320 {
1321   breakpoint_smob_tag
1322     = gdbscm_make_smob_type (breakpoint_smob_name, sizeof (breakpoint_smob));
1323   scm_set_smob_free (breakpoint_smob_tag, bpscm_free_breakpoint_smob);
1324   scm_set_smob_print (breakpoint_smob_tag, bpscm_print_breakpoint_smob);
1325
1326   gdb::observers::breakpoint_created.attach (bpscm_breakpoint_created,
1327                                              "scm-breakpoint");
1328   gdb::observers::breakpoint_deleted.attach (bpscm_breakpoint_deleted,
1329                                              "scm-breakpoint");
1330
1331   gdbscm_define_integer_constants (breakpoint_integer_constants, 1);
1332   gdbscm_define_functions (breakpoint_functions, 1);
1333
1334   type_keyword = scm_from_latin1_keyword ("type");
1335   wp_class_keyword = scm_from_latin1_keyword ("wp-class");
1336   internal_keyword = scm_from_latin1_keyword ("internal");
1337 }