gdb/guile/scm-breakpoint.c

   1 /* Scheme interface to breakpoints.
   2
   3    Copyright (C) 2008-2015 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 "observer.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);
 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   struct gdb_exception except = exception_none;
 415   char *location, *copy;
 416   struct event_location *eloc;
 417   struct cleanup *cleanup;
 418
 419   /* We only support registering breakpoints created with make-breakpoint.  */
 420   if (!bp_smob->is_scheme_bkpt)
 421     scm_misc_error (FUNC_NAME, _("not a Scheme breakpoint"), SCM_EOL);
 422
 423   if (bpscm_is_valid (bp_smob))
 424     scm_misc_error (FUNC_NAME, _("breakpoint is already registered"), SCM_EOL);
 425
 426   pending_breakpoint_scm = self;
 427   location = bp_smob->spec.location;
 428   copy = location;
 429   eloc = new_linespec_location (&copy);
 430   cleanup = make_cleanup_delete_event_location (eloc);
 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, 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 (ex, RETURN_MASK_ALL)
 469     {
 470       except = ex;
 471     }
 472   END_CATCH
 473
 474   /* Ensure this gets reset, even if there's an error.  */
 475   pending_breakpoint_scm = SCM_BOOL_F;
 476   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 477   do_cleanups (cleanup);
 478
 479   return SCM_UNSPECIFIED;
 480 }
 481
 482 /* (delete-breakpoint! <gdb:breakpoint>) -> unspecified
 483    Scheme function which deletes (removes) the underlying GDB breakpoint
 484    from GDB's list of breakpoints.  This triggers the breakpoint_deleted
 485    observer which will call gdbscm_breakpoint_deleted; that function cleans
 486    up the Scheme bits.  */
 487
 488 static SCM
 489 gdbscm_delete_breakpoint_x (SCM self)
 490 {
 491   breakpoint_smob *bp_smob
 492     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 493
 494   TRY
 495     {
 496       delete_breakpoint (bp_smob->bp);
 497     }
 498   CATCH (except, RETURN_MASK_ALL)
 499     {
 500       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 501     }
 502   END_CATCH
 503
 504   return SCM_UNSPECIFIED;
 505 }
 506
 507 /* iterate_over_breakpoints function for gdbscm_breakpoints.  */
 508
 509 static int
 510 bpscm_build_bp_list (struct breakpoint *bp, void *arg)
 511 {
 512   SCM *list = (SCM *) arg;
 513   breakpoint_smob *bp_smob = bp->scm_bp_object;
 514
 515   /* Lazily create wrappers for breakpoints created outside Scheme.  */
 516
 517   if (bp_smob == NULL)
 518     {
 519       if (bpscm_want_scm_wrapper_p (bp, 0))
 520         {
 521           SCM bp_scm;
 522
 523           bp_scm = bpscm_make_breakpoint_smob ();
 524           bpscm_attach_scm_to_breakpoint (bp, bp_scm);
 525           /* Refetch it.  */
 526           bp_smob = bp->scm_bp_object;
 527         }
 528     }
 529
 530   /* Not all breakpoints will have a companion Scheme object.
 531      Only breakpoints that trigger the created_breakpoint observer call,
 532      and satisfy certain conditions (see bpscm_want_scm_wrapper_p),
 533      get a companion object (this includes Scheme-created breakpoints).  */
 534
 535   if (bp_smob != NULL)
 536     *list = scm_cons (bp_smob->containing_scm, *list);
 537
 538   return 0;
 539 }
 540
 541 /* (breakpoints) -> list
 542    Return a list of all breakpoints.  */
 543
 544 static SCM
 545 gdbscm_breakpoints (void)
 546 {
 547   SCM list = SCM_EOL;
 548
 549   /* If iterate_over_breakpoints returns non-NULL it means the iteration
 550      terminated early.
 551      In that case abandon building the list and return #f.  */
 552   if (iterate_over_breakpoints (bpscm_build_bp_list, &list) != NULL)
 553     return SCM_BOOL_F;
 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   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 (except, RETURN_MASK_ALL)
 600     {
 601       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 602     }
 603   END_CATCH
 604
 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   TRY
 631     {
 632       breakpoint_set_silent (bp_smob->bp, gdbscm_is_true (newvalue));
 633     }
 634   CATCH (except, RETURN_MASK_ALL)
 635     {
 636       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 637     }
 638   END_CATCH
 639
 640   return SCM_UNSPECIFIED;
 641 }
 642
 643 /* (breakpoint-ignore-count <gdb:breakpoint>) -> integer */
 644
 645 static SCM
 646 gdbscm_breakpoint_ignore_count (SCM self)
 647 {
 648   breakpoint_smob *bp_smob
 649     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 650
 651   return scm_from_long (bp_smob->bp->ignore_count);
 652 }
 653
 654 /* (set-breakpoint-ignore-count! <gdb:breakpoint> integer)
 655      -> unspecified */
 656
 657 static SCM
 658 gdbscm_set_breakpoint_ignore_count_x (SCM self, SCM newvalue)
 659 {
 660   breakpoint_smob *bp_smob
 661     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 662   long value;
 663
 664   SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX),
 665                    newvalue, SCM_ARG2, FUNC_NAME, _("integer"));
 666
 667   value = scm_to_long (newvalue);
 668   if (value < 0)
 669     value = 0;
 670
 671   TRY
 672     {
 673       set_ignore_count (bp_smob->number, (int) value, 0);
 674     }
 675   CATCH (except, RETURN_MASK_ALL)
 676     {
 677       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 678     }
 679   END_CATCH
 680
 681   return SCM_UNSPECIFIED;
 682 }
 683
 684 /* (breakpoint-hit-count <gdb:breakpoint>) -> integer */
 685
 686 static SCM
 687 gdbscm_breakpoint_hit_count (SCM self)
 688 {
 689   breakpoint_smob *bp_smob
 690     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 691
 692   return scm_from_long (bp_smob->bp->hit_count);
 693 }
 694
 695 /* (set-breakpoint-hit-count! <gdb:breakpoint> integer) -> unspecified */
 696
 697 static SCM
 698 gdbscm_set_breakpoint_hit_count_x (SCM self, SCM newvalue)
 699 {
 700   breakpoint_smob *bp_smob
 701     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 702   long value;
 703
 704   SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX),
 705                    newvalue, SCM_ARG2, FUNC_NAME, _("integer"));
 706
 707   value = scm_to_long (newvalue);
 708   if (value < 0)
 709     value = 0;
 710
 711   if (value != 0)
 712     {
 713       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 714                                  _("hit-count must be zero"));
 715     }
 716
 717   bp_smob->bp->hit_count = 0;
 718
 719   return SCM_UNSPECIFIED;
 720 }
 721
 722 /* (breakpoint-thread <gdb:breakpoint>) -> integer */
 723
 724 static SCM
 725 gdbscm_breakpoint_thread (SCM self)
 726 {
 727   breakpoint_smob *bp_smob
 728     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 729
 730   if (bp_smob->bp->thread == -1)
 731     return SCM_BOOL_F;
 732
 733   return scm_from_long (bp_smob->bp->thread);
 734 }
 735
 736 /* (set-breakpoint-thread! <gdb:breakpoint> integer) -> unspecified */
 737
 738 static SCM
 739 gdbscm_set_breakpoint_thread_x (SCM self, SCM newvalue)
 740 {
 741   breakpoint_smob *bp_smob
 742     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 743   long id;
 744
 745   if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
 746     {
 747       id = scm_to_long (newvalue);
 748       if (! valid_thread_id (id))
 749         {
 750           gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 751                                      _("invalid thread id"));
 752         }
 753     }
 754   else if (gdbscm_is_false (newvalue))
 755     id = -1;
 756   else
 757     SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f"));
 758
 759   breakpoint_set_thread (bp_smob->bp, id);
 760
 761   return SCM_UNSPECIFIED;
 762 }
 763
 764 /* (breakpoint-task <gdb:breakpoint>) -> integer */
 765
 766 static SCM
 767 gdbscm_breakpoint_task (SCM self)
 768 {
 769   breakpoint_smob *bp_smob
 770     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 771
 772   if (bp_smob->bp->task == 0)
 773     return SCM_BOOL_F;
 774
 775   return scm_from_long (bp_smob->bp->task);
 776 }
 777
 778 /* (set-breakpoint-task! <gdb:breakpoint> integer) -> unspecified */
 779
 780 static SCM
 781 gdbscm_set_breakpoint_task_x (SCM self, SCM newvalue)
 782 {
 783   breakpoint_smob *bp_smob
 784     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 785   long id;
 786   int valid_id = 0;
 787
 788   if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
 789     {
 790       id = scm_to_long (newvalue);
 791
 792       TRY
 793         {
 794           valid_id = valid_task_id (id);
 795         }
 796       CATCH (except, RETURN_MASK_ALL)
 797         {
 798           GDBSCM_HANDLE_GDB_EXCEPTION (except);
 799         }
 800       END_CATCH
 801
 802       if (! valid_id)
 803         {
 804           gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
 805                                      _("invalid task id"));
 806         }
 807     }
 808   else if (gdbscm_is_false (newvalue))
 809     id = 0;
 810   else
 811     SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f"));
 812
 813   TRY
 814     {
 815       breakpoint_set_task (bp_smob->bp, id);
 816     }
 817   CATCH (except, RETURN_MASK_ALL)
 818     {
 819       GDBSCM_HANDLE_GDB_EXCEPTION (except);
 820     }
 821   END_CATCH
 822
 823   return SCM_UNSPECIFIED;
 824 }
 825
 826 /* (breakpoint-location <gdb:breakpoint>) -> string */
 827
 828 static SCM
 829 gdbscm_breakpoint_location (SCM self)
 830 {
 831   breakpoint_smob *bp_smob
 832     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 833   const char *str;
 834
 835   if (bp_smob->bp->type != bp_breakpoint)
 836     return SCM_BOOL_F;
 837
 838   str = event_location_to_string (bp_smob->bp->location);
 839   if (! str)
 840     str = "";
 841
 842   return gdbscm_scm_from_c_string (str);
 843 }
 844
 845 /* (breakpoint-expression <gdb:breakpoint>) -> string
 846    This is only valid for watchpoints.
 847    Returns #f for non-watchpoints.  */
 848
 849 static SCM
 850 gdbscm_breakpoint_expression (SCM self)
 851 {
 852   breakpoint_smob *bp_smob
 853     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 854   char *str;
 855   struct watchpoint *wp;
 856
 857   if (!is_watchpoint (bp_smob->bp))
 858     return SCM_BOOL_F;
 859
 860   wp = (struct watchpoint *) bp_smob->bp;
 861
 862   str = wp->exp_string;
 863   if (! str)
 864     str = "";
 865
 866   return gdbscm_scm_from_c_string (str);
 867 }
 868
 869 /* (breakpoint-condition <gdb:breakpoint>) -> string */
 870
 871 static SCM
 872 gdbscm_breakpoint_condition (SCM self)
 873 {
 874   breakpoint_smob *bp_smob
 875     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 876   char *str;
 877
 878   str = bp_smob->bp->cond_string;
 879   if (! str)
 880     return SCM_BOOL_F;
 881
 882   return gdbscm_scm_from_c_string (str);
 883 }
 884
 885 /* (set-breakpoint-condition! <gdb:breakpoint> string|#f)
 886    -> unspecified */
 887
 888 static SCM
 889 gdbscm_set_breakpoint_condition_x (SCM self, SCM newvalue)
 890 {
 891   breakpoint_smob *bp_smob
 892     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 893   char *exp;
 894   struct gdb_exception except = exception_none;
 895
 896   SCM_ASSERT_TYPE (scm_is_string (newvalue) || gdbscm_is_false (newvalue),
 897                    newvalue, SCM_ARG2, FUNC_NAME,
 898                    _("string or #f"));
 899
 900   if (gdbscm_is_false (newvalue))
 901     exp = NULL;
 902   else
 903     exp = gdbscm_scm_to_c_string (newvalue);
 904
 905   TRY
 906     {
 907       set_breakpoint_condition (bp_smob->bp, exp ? exp : "", 0);
 908     }
 909   CATCH (ex, RETURN_MASK_ALL)
 910     {
 911       except = ex;
 912     }
 913   END_CATCH
 914
 915   xfree (exp);
 916   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 917
 918   return SCM_UNSPECIFIED;
 919 }
 920
 921 /* (breakpoint-stop <gdb:breakpoint>) -> procedure or #f */
 922
 923 static SCM
 924 gdbscm_breakpoint_stop (SCM self)
 925 {
 926   breakpoint_smob *bp_smob
 927     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 928
 929   return bp_smob->stop;
 930 }
 931
 932 /* (set-breakpoint-stop! <gdb:breakpoint> procedure|#f)
 933    -> unspecified */
 934
 935 static SCM
 936 gdbscm_set_breakpoint_stop_x (SCM self, SCM newvalue)
 937 {
 938   breakpoint_smob *bp_smob
 939     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 940   const struct extension_language_defn *extlang = NULL;
 941
 942   SCM_ASSERT_TYPE (gdbscm_is_procedure (newvalue)
 943                    || gdbscm_is_false (newvalue),
 944                    newvalue, SCM_ARG2, FUNC_NAME,
 945                    _("procedure or #f"));
 946
 947   if (bp_smob->bp->cond_string != NULL)
 948     extlang = get_ext_lang_defn (EXT_LANG_GDB);
 949   if (extlang == NULL)
 950     extlang = get_breakpoint_cond_ext_lang (bp_smob->bp, EXT_LANG_GUILE);
 951   if (extlang != NULL)
 952     {
 953       char *error_text
 954         = xstrprintf (_("Only one stop condition allowed.  There is"
 955                         " currently a %s stop condition defined for"
 956                         " this breakpoint."),
 957                       ext_lang_capitalized_name (extlang));
 958
 959       scm_dynwind_begin (0);
 960       gdbscm_dynwind_xfree (error_text);
 961       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self, error_text);
 962       /* The following line, while unnecessary, is present for completeness
 963          sake.  */
 964       scm_dynwind_end ();
 965     }
 966
 967   bp_smob->stop = newvalue;
 968
 969   return SCM_UNSPECIFIED;
 970 }
 971
 972 /* (breakpoint-commands <gdb:breakpoint>) -> string */
 973
 974 static SCM
 975 gdbscm_breakpoint_commands (SCM self)
 976 {
 977   breakpoint_smob *bp_smob
 978     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 979   struct breakpoint *bp;
 980   long length;
 981   struct ui_file *string_file;
 982   struct cleanup *chain;
 983   SCM result;
 984   char *cmdstr;
 985
 986   bp = bp_smob->bp;
 987
 988   if (bp->commands == NULL)
 989     return SCM_BOOL_F;
 990
 991   string_file = mem_fileopen ();
 992   chain = make_cleanup_ui_file_delete (string_file);
 993
 994   ui_out_redirect (current_uiout, string_file);
 995   TRY
 996     {
 997       print_command_lines (current_uiout, breakpoint_commands (bp), 0);
 998     }
 999   ui_out_redirect (current_uiout, NULL);
1000   CATCH (except, RETURN_MASK_ALL)
1001     {
1002       do_cleanups (chain);
1003       gdbscm_throw_gdb_exception (except);
1004     }
1005   END_CATCH
1006
1007   cmdstr = ui_file_xstrdup (string_file, &length);
1008   make_cleanup (xfree, cmdstr);
1009   result = gdbscm_scm_from_c_string (cmdstr);
1010
1011   do_cleanups (chain);
1012   return result;
1013 }
1014
1015 /* (breakpoint-type <gdb:breakpoint>) -> integer */
1016
1017 static SCM
1018 gdbscm_breakpoint_type (SCM self)
1019 {
1020   breakpoint_smob *bp_smob
1021     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1022
1023   return scm_from_long (bp_smob->bp->type);
1024 }
1025
1026 /* (breakpoint-visible? <gdb:breakpoint>) -> boolean */
1027
1028 static SCM
1029 gdbscm_breakpoint_visible (SCM self)
1030 {
1031   breakpoint_smob *bp_smob
1032     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1033
1034   return scm_from_bool (bp_smob->bp->number >= 0);
1035 }
1036
1037 /* (breakpoint-number <gdb:breakpoint>) -> integer */
1038
1039 static SCM
1040 gdbscm_breakpoint_number (SCM self)
1041 {
1042   breakpoint_smob *bp_smob
1043     = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
1044
1045   return scm_from_long (bp_smob->number);
1046 }
1047 \f
1048 /* Return TRUE if "stop" has been set for this breakpoint.
1049
1050    This is the extension_language_ops.breakpoint_has_cond "method".  */
1051
1052 int
1053 gdbscm_breakpoint_has_cond (const struct extension_language_defn *extlang,
1054                             struct breakpoint *b)
1055 {
1056   breakpoint_smob *bp_smob = b->scm_bp_object;
1057
1058   if (bp_smob == NULL)
1059     return 0;
1060
1061   return gdbscm_is_procedure (bp_smob->stop);
1062 }
1063
1064 /* Call the "stop" method in the breakpoint class.
1065    This must only be called if gdbscm_breakpoint_has_cond returns true.
1066    If the stop method returns #t, the inferior will be stopped at the
1067    breakpoint.  Otherwise the inferior will be allowed to continue
1068    (assuming other conditions don't indicate "stop").
1069
1070    This is the extension_language_ops.breakpoint_cond_says_stop "method".  */
1071
1072 enum ext_lang_bp_stop
1073 gdbscm_breakpoint_cond_says_stop
1074   (const struct extension_language_defn *extlang, struct breakpoint *b)
1075 {
1076   breakpoint_smob *bp_smob = b->scm_bp_object;
1077   SCM predicate_result;
1078   int stop;
1079
1080   if (bp_smob == NULL)
1081     return EXT_LANG_BP_STOP_UNSET;
1082   if (!gdbscm_is_procedure (bp_smob->stop))
1083     return EXT_LANG_BP_STOP_UNSET;
1084
1085   stop = 1;
1086
1087   predicate_result
1088     = gdbscm_safe_call_1 (bp_smob->stop, bp_smob->containing_scm, NULL);
1089
1090   if (gdbscm_is_exception (predicate_result))
1091     ; /* Exception already printed.  */
1092   /* If the "stop" function returns #f that means
1093      the Scheme breakpoint wants GDB to continue.  */
1094   else if (gdbscm_is_false (predicate_result))
1095     stop = 0;
1096
1097   return stop ? EXT_LANG_BP_STOP_YES : EXT_LANG_BP_STOP_NO;
1098 }
1099 \f
1100 /* Event callback functions.  */
1101
1102 /* Callback that is used when a breakpoint is created.
1103    For breakpoints created by Scheme, i.e., gdbscm_create_breakpoint_x, finish
1104    object creation by connecting the Scheme wrapper to the gdb object.
1105    We ignore breakpoints created from gdb or python here, we create the
1106    Scheme wrapper for those when there's a need to, e.g.,
1107    gdbscm_breakpoints.  */
1108
1109 static void
1110 bpscm_breakpoint_created (struct breakpoint *bp)
1111 {
1112   SCM bp_scm;
1113
1114   if (gdbscm_is_false (pending_breakpoint_scm))
1115     return;
1116
1117   /* Verify our caller error checked the user's request.  */
1118   gdb_assert (bpscm_want_scm_wrapper_p (bp, 1));
1119
1120   bp_scm = pending_breakpoint_scm;
1121   pending_breakpoint_scm = SCM_BOOL_F;
1122
1123   bpscm_attach_scm_to_breakpoint (bp, bp_scm);
1124 }
1125
1126 /* Callback that is used when a breakpoint is deleted.  This will
1127    invalidate the corresponding Scheme object.  */
1128
1129 static void
1130 bpscm_breakpoint_deleted (struct breakpoint *b)
1131 {
1132   int num = b->number;
1133   struct breakpoint *bp;
1134
1135   /* TODO: Why the lookup?  We have B.  */
1136
1137   bp = get_breakpoint (num);
1138   if (bp)
1139     {
1140       breakpoint_smob *bp_smob = bp->scm_bp_object;
1141
1142       if (bp_smob)
1143         {
1144           bp_smob->bp = NULL;
1145           bp_smob->number = -1;
1146           bp_smob->stop = SCM_BOOL_F;
1147           scm_gc_unprotect_object (bp_smob->containing_scm);
1148         }
1149     }
1150 }
1151 \f
1152 /* Initialize the Scheme breakpoint code.  */
1153
1154 static const scheme_integer_constant breakpoint_integer_constants[] =
1155 {
1156   { "BP_NONE", bp_none },
1157   { "BP_BREAKPOINT", bp_breakpoint },
1158   { "BP_WATCHPOINT", bp_watchpoint },
1159   { "BP_HARDWARE_WATCHPOINT", bp_hardware_watchpoint },
1160   { "BP_READ_WATCHPOINT", bp_read_watchpoint },
1161   { "BP_ACCESS_WATCHPOINT", bp_access_watchpoint },
1162
1163   { "WP_READ", hw_read },
1164   { "WP_WRITE", hw_write },
1165   { "WP_ACCESS", hw_access },
1166
1167   END_INTEGER_CONSTANTS
1168 };
1169
1170 static const scheme_function breakpoint_functions[] =
1171 {
1172   { "make-breakpoint", 1, 0, 1, as_a_scm_t_subr (gdbscm_make_breakpoint),
1173     "\
1174 Create a GDB breakpoint object.\n\
1175 \n\
1176   Arguments:\n\
1177     location [#:type <type>] [#:wp-class <wp-class>] [#:internal <bool>]\n\
1178   Returns:\n\
1179     <gdb:breakpoint object" },
1180
1181   { "register-breakpoint!", 1, 0, 0,
1182     as_a_scm_t_subr (gdbscm_register_breakpoint_x),
1183     "\
1184 Register a <gdb:breakpoint> object with GDB." },
1185
1186   { "delete-breakpoint!", 1, 0, 0, as_a_scm_t_subr (gdbscm_delete_breakpoint_x),
1187     "\
1188 Delete the breakpoint from GDB." },
1189
1190   { "breakpoints", 0, 0, 0, as_a_scm_t_subr (gdbscm_breakpoints),
1191     "\
1192 Return a list of all GDB breakpoints.\n\
1193 \n\
1194   Arguments: none" },
1195
1196   { "breakpoint?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_p),
1197     "\
1198 Return #t if the object is a <gdb:breakpoint> object." },
1199
1200   { "breakpoint-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_valid_p),
1201     "\
1202 Return #t if the breakpoint has not been deleted from GDB." },
1203
1204   { "breakpoint-number", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_number),
1205     "\
1206 Return the breakpoint's number." },
1207
1208   { "breakpoint-type", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_type),
1209     "\
1210 Return the type of the breakpoint." },
1211
1212   { "breakpoint-visible?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_visible),
1213     "\
1214 Return #t if the breakpoint is visible to the user." },
1215
1216   { "breakpoint-location", 1, 0, 0,
1217     as_a_scm_t_subr (gdbscm_breakpoint_location),
1218     "\
1219 Return the location of the breakpoint as specified by the user." },
1220
1221   { "breakpoint-expression", 1, 0, 0,
1222     as_a_scm_t_subr (gdbscm_breakpoint_expression),
1223     "\
1224 Return the expression of the breakpoint as specified by the user.\n\
1225 Valid for watchpoints only, returns #f for non-watchpoints." },
1226
1227   { "breakpoint-enabled?", 1, 0, 0,
1228     as_a_scm_t_subr (gdbscm_breakpoint_enabled_p),
1229     "\
1230 Return #t if the breakpoint is enabled." },
1231
1232   { "set-breakpoint-enabled!", 2, 0, 0,
1233     as_a_scm_t_subr (gdbscm_set_breakpoint_enabled_x),
1234     "\
1235 Set the breakpoint's enabled state.\n\
1236 \n\
1237   Arguments: <gdb:breakpoint> boolean" },
1238
1239   { "breakpoint-silent?", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_silent_p),
1240     "\
1241 Return #t if the breakpoint is silent." },
1242
1243   { "set-breakpoint-silent!", 2, 0, 0,
1244     as_a_scm_t_subr (gdbscm_set_breakpoint_silent_x),
1245     "\
1246 Set the breakpoint's silent state.\n\
1247 \n\
1248   Arguments: <gdb:breakpoint> boolean" },
1249
1250   { "breakpoint-ignore-count", 1, 0, 0,
1251     as_a_scm_t_subr (gdbscm_breakpoint_ignore_count),
1252     "\
1253 Return the breakpoint's \"ignore\" count." },
1254
1255   { "set-breakpoint-ignore-count!", 2, 0, 0,
1256     as_a_scm_t_subr (gdbscm_set_breakpoint_ignore_count_x),
1257     "\
1258 Set the breakpoint's \"ignore\" count.\n\
1259 \n\
1260   Arguments: <gdb:breakpoint> count" },
1261
1262   { "breakpoint-hit-count", 1, 0, 0,
1263     as_a_scm_t_subr (gdbscm_breakpoint_hit_count),
1264     "\
1265 Return the breakpoint's \"hit\" count." },
1266
1267   { "set-breakpoint-hit-count!", 2, 0, 0,
1268     as_a_scm_t_subr (gdbscm_set_breakpoint_hit_count_x),
1269     "\
1270 Set the breakpoint's \"hit\" count.  The value must be zero.\n\
1271 \n\
1272   Arguments: <gdb:breakpoint> 0" },
1273
1274   { "breakpoint-thread", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_thread),
1275     "\
1276 Return the breakpoint's thread id or #f if there isn't one." },
1277
1278   { "set-breakpoint-thread!", 2, 0, 0,
1279     as_a_scm_t_subr (gdbscm_set_breakpoint_thread_x),
1280     "\
1281 Set the thread id for this breakpoint.\n\
1282 \n\
1283   Arguments: <gdb:breakpoint> thread-id" },
1284
1285   { "breakpoint-task", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_task),
1286     "\
1287 Return the breakpoint's Ada task-id or #f if there isn't one." },
1288
1289   { "set-breakpoint-task!", 2, 0, 0,
1290     as_a_scm_t_subr (gdbscm_set_breakpoint_task_x),
1291     "\
1292 Set the breakpoint's Ada task-id.\n\
1293 \n\
1294   Arguments: <gdb:breakpoint> task-id" },
1295
1296   { "breakpoint-condition", 1, 0, 0,
1297     as_a_scm_t_subr (gdbscm_breakpoint_condition),
1298     "\
1299 Return the breakpoint's condition as specified by the user.\n\
1300 Return #f if there isn't one." },
1301
1302   { "set-breakpoint-condition!", 2, 0, 0,
1303     as_a_scm_t_subr (gdbscm_set_breakpoint_condition_x),
1304     "\
1305 Set the breakpoint's condition.\n\
1306 \n\
1307   Arguments: <gdb:breakpoint> condition\n\
1308     condition: a string" },
1309
1310   { "breakpoint-stop", 1, 0, 0, as_a_scm_t_subr (gdbscm_breakpoint_stop),
1311     "\
1312 Return the breakpoint's stop predicate.\n\
1313 Return #f if there isn't one." },
1314
1315   { "set-breakpoint-stop!", 2, 0, 0,
1316     as_a_scm_t_subr (gdbscm_set_breakpoint_stop_x),
1317     "\
1318 Set the breakpoint's stop predicate.\n\
1319 \n\
1320   Arguments: <gdb:breakpoint> procedure\n\
1321     procedure: A procedure of one argument, the breakpoint.\n\
1322       Its result is true if program execution should stop." },
1323
1324   { "breakpoint-commands", 1, 0, 0,
1325     as_a_scm_t_subr (gdbscm_breakpoint_commands),
1326     "\
1327 Return the breakpoint's commands." },
1328
1329   END_FUNCTIONS
1330 };
1331
1332 void
1333 gdbscm_initialize_breakpoints (void)
1334 {
1335   breakpoint_smob_tag
1336     = gdbscm_make_smob_type (breakpoint_smob_name, sizeof (breakpoint_smob));
1337   scm_set_smob_free (breakpoint_smob_tag, bpscm_free_breakpoint_smob);
1338   scm_set_smob_print (breakpoint_smob_tag, bpscm_print_breakpoint_smob);
1339
1340   observer_attach_breakpoint_created (bpscm_breakpoint_created);
1341   observer_attach_breakpoint_deleted (bpscm_breakpoint_deleted);
1342
1343   gdbscm_define_integer_constants (breakpoint_integer_constants, 1);
1344   gdbscm_define_functions (breakpoint_functions, 1);
1345
1346   type_keyword = scm_from_latin1_keyword ("type");
1347   wp_class_keyword = scm_from_latin1_keyword ("wp-class");
1348   internal_keyword = scm_from_latin1_keyword ("internal");
1349 }