gdb/guile/scm-breakpoint.c

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