gdb/guile/scm-breakpoint.c

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