gdb/guile/scm-breakpoint.c

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