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