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