gdb/guile/scm-block.c

   1 /* Scheme interface to blocks.
   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 "block.h"
  25 #include "dictionary.h"
  26 #include "objfiles.h"
  27 #include "source.h"
  28 #include "symtab.h"
  29 #include "guile-internal.h"
  30
  31 /* A smob describing a gdb block.  */
  32
  33 typedef struct _block_smob
  34 {
  35   /* This always appears first.
  36      We want blocks to be eq?-able.  And we need to be able to invalidate
  37      blocks when the associated objfile is deleted.  */
  38   eqable_gdb_smob base;
  39
  40   /* The GDB block structure that represents a frame's code block.  */
  41   const struct block *block;
  42
  43   /* The backing object file.  There is no direct relationship in GDB
  44      between a block and an object file.  When a block is created also
  45      store a pointer to the object file for later use.  */
  46   struct objfile *objfile;
  47 } block_smob;
  48
  49 /* To iterate over block symbols from Scheme we need to store
  50    struct block_iterator somewhere.  This is stored in the "progress" field
  51    of <gdb:iterator>.  We store the block object in iterator_smob.object,
  52    so we don't store it here.
  53
  54    Remember: While iterating over block symbols, you must continually check
  55    whether the block is still valid.  */
  56
  57 typedef struct
  58 {
  59   /* This always appears first.  */
  60   gdb_smob base;
  61
  62   /* The iterator for that block.  */
  63   struct block_iterator iter;
  64
  65   /* Has the iterator been initialized flag.  */
  66   int initialized_p;
  67 } block_syms_progress_smob;
  68
  69 static const char block_smob_name[] = "gdb:block";
  70 static const char block_syms_progress_smob_name[] = "gdb:block-symbols-iterator";
  71
  72 /* The tag Guile knows the block smobs by.  */
  73 static scm_t_bits block_smob_tag;
  74 static scm_t_bits block_syms_progress_smob_tag;
  75
  76 /* The "next!" block syms iterator method.  */
  77 static SCM bkscm_next_symbol_x_proc;
  78
  79 static const struct objfile_data *bkscm_objfile_data_key;
  80 \f
  81 /* Administrivia for block smobs.  */
  82
  83 /* Helper function to hash a block_smob.  */
  84
  85 static hashval_t
  86 bkscm_hash_block_smob (const void *p)
  87 {
  88   const block_smob *b_smob = p;
  89
  90   return htab_hash_pointer (b_smob->block);
  91 }
  92
  93 /* Helper function to compute equality of block_smobs.  */
  94
  95 static int
  96 bkscm_eq_block_smob (const void *ap, const void *bp)
  97 {
  98   const block_smob *a = ap;
  99   const block_smob *b = bp;
 100
 101   return (a->block == b->block
 102           && a->block != NULL);
 103 }
 104
 105 /* Return the struct block pointer -> SCM mapping table.
 106    It is created if necessary.  */
 107
 108 static htab_t
 109 bkscm_objfile_block_map (struct objfile *objfile)
 110 {
 111   htab_t htab = objfile_data (objfile, bkscm_objfile_data_key);
 112
 113   if (htab == NULL)
 114     {
 115       htab = gdbscm_create_eqable_gsmob_ptr_map (bkscm_hash_block_smob,
 116                                                  bkscm_eq_block_smob);
 117       set_objfile_data (objfile, bkscm_objfile_data_key, htab);
 118     }
 119
 120   return htab;
 121 }
 122
 123 /* The smob "mark" function for <gdb:block>.  */
 124
 125 static SCM
 126 bkscm_mark_block_smob (SCM self)
 127 {
 128   block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
 129
 130   /* Do this last.  */
 131   return gdbscm_mark_eqable_gsmob (&b_smob->base);
 132 }
 133
 134 /* The smob "free" function for <gdb:block>.  */
 135
 136 static size_t
 137 bkscm_free_block_smob (SCM self)
 138 {
 139   block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
 140
 141   if (b_smob->block != NULL)
 142     {
 143       htab_t htab = bkscm_objfile_block_map (b_smob->objfile);
 144
 145       gdbscm_clear_eqable_gsmob_ptr_slot (htab, &b_smob->base);
 146     }
 147
 148   /* Not necessary, done to catch bugs.  */
 149   b_smob->block = NULL;
 150   b_smob->objfile = NULL;
 151
 152   return 0;
 153 }
 154
 155 /* The smob "print" function for <gdb:block>.  */
 156
 157 static int
 158 bkscm_print_block_smob (SCM self, SCM port, scm_print_state *pstate)
 159 {
 160   block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
 161   const struct block *b = b_smob->block;
 162
 163   gdbscm_printf (port, "#<%s", block_smob_name);
 164
 165   if (BLOCK_SUPERBLOCK (b) == NULL)
 166     gdbscm_printf (port, " global");
 167   else if (BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (b)) == NULL)
 168     gdbscm_printf (port, " static");
 169
 170   if (BLOCK_FUNCTION (b) != NULL)
 171     gdbscm_printf (port, " %s", SYMBOL_PRINT_NAME (BLOCK_FUNCTION (b)));
 172
 173   gdbscm_printf (port, " %s-%s",
 174                  hex_string (BLOCK_START (b)), hex_string (BLOCK_END (b)));
 175
 176   scm_puts (">", port);
 177
 178   scm_remember_upto_here_1 (self);
 179
 180   /* Non-zero means success.  */
 181   return 1;
 182 }
 183
 184 /* Low level routine to create a <gdb:block> object.  */
 185
 186 static SCM
 187 bkscm_make_block_smob (void)
 188 {
 189   block_smob *b_smob = (block_smob *)
 190     scm_gc_malloc (sizeof (block_smob), block_smob_name);
 191   SCM b_scm;
 192
 193   b_smob->block = NULL;
 194   b_smob->objfile = NULL;
 195   b_scm = scm_new_smob (block_smob_tag, (scm_t_bits) b_smob);
 196   gdbscm_init_eqable_gsmob (&b_smob->base);
 197
 198   return b_scm;
 199 }
 200
 201 /* Returns non-zero if SCM is a <gdb:block> object.  */
 202
 203 static int
 204 bkscm_is_block (SCM scm)
 205 {
 206   return SCM_SMOB_PREDICATE (block_smob_tag, scm);
 207 }
 208
 209 /* (block? scm) -> boolean */
 210
 211 static SCM
 212 gdbscm_block_p (SCM scm)
 213 {
 214   return scm_from_bool (bkscm_is_block (scm));
 215 }
 216
 217 /* Return the existing object that encapsulates BLOCK, or create a new
 218    <gdb:block> object.  */
 219
 220 SCM
 221 bkscm_scm_from_block (const struct block *block, struct objfile *objfile)
 222 {
 223   htab_t htab;
 224   eqable_gdb_smob **slot;
 225   block_smob *b_smob, b_smob_for_lookup;
 226   SCM b_scm;
 227
 228   /* If we've already created a gsmob for this block, return it.
 229      This makes blocks eq?-able.  */
 230   htab = bkscm_objfile_block_map (objfile);
 231   b_smob_for_lookup.block = block;
 232   slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &b_smob_for_lookup.base);
 233   if (*slot != NULL)
 234     return (*slot)->containing_scm;
 235
 236   b_scm = bkscm_make_block_smob ();
 237   b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
 238   b_smob->block = block;
 239   b_smob->objfile = objfile;
 240   gdbscm_fill_eqable_gsmob_ptr_slot (slot, &b_smob->base, b_scm);
 241
 242   return b_scm;
 243 }
 244
 245 /* Returns the <gdb:block> object in SELF.
 246    Throws an exception if SELF is not a <gdb:block> object.  */
 247
 248 static SCM
 249 bkscm_get_block_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 250 {
 251   SCM_ASSERT_TYPE (bkscm_is_block (self), self, arg_pos, func_name,
 252                    block_smob_name);
 253
 254   return self;
 255 }
 256
 257 /* Returns a pointer to the block smob of SELF.
 258    Throws an exception if SELF is not a <gdb:block> object.  */
 259
 260 static block_smob *
 261 bkscm_get_block_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
 262 {
 263   SCM b_scm = bkscm_get_block_arg_unsafe (self, arg_pos, func_name);
 264   block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
 265
 266   return b_smob;
 267 }
 268
 269 /* Returns non-zero if block B_SMOB is valid.  */
 270
 271 static int
 272 bkscm_is_valid (block_smob *b_smob)
 273 {
 274   return b_smob->block != NULL;
 275 }
 276
 277 /* Returns the block smob in SELF, verifying it's valid.
 278    Throws an exception if SELF is not a <gdb:block> object or is invalid.  */
 279
 280 static block_smob *
 281 bkscm_get_valid_block_smob_arg_unsafe (SCM self, int arg_pos,
 282                                        const char *func_name)
 283 {
 284   block_smob *b_smob
 285     = bkscm_get_block_smob_arg_unsafe (self, arg_pos, func_name);
 286
 287   if (!bkscm_is_valid (b_smob))
 288     {
 289       gdbscm_invalid_object_error (func_name, arg_pos, self,
 290                                    _("<gdb:block>"));
 291     }
 292
 293   return b_smob;
 294 }
 295
 296 /* Returns the block smob contained in SCM or NULL if SCM is not a
 297    <gdb:block> object.
 298    If there is an error a <gdb:exception> object is stored in *EXCP.  */
 299
 300 static block_smob *
 301 bkscm_get_valid_block (SCM scm, int arg_pos, const char *func_name, SCM *excp)
 302 {
 303   block_smob *b_smob;
 304
 305   if (!bkscm_is_block (scm))
 306     {
 307       *excp = gdbscm_make_type_error (func_name, arg_pos, scm,
 308                                       block_smob_name);
 309       return NULL;
 310     }
 311
 312   b_smob = (block_smob *) SCM_SMOB_DATA (scm);
 313   if (!bkscm_is_valid (b_smob))
 314     {
 315       *excp = gdbscm_make_invalid_object_error (func_name, arg_pos, scm,
 316                                                 _("<gdb:block>"));
 317       return NULL;
 318     }
 319
 320   return b_smob;
 321 }
 322
 323 /* Returns the struct block that is wrapped by BLOCK_SCM.
 324    If BLOCK_SCM is not a block, or is an invalid block, then NULL is returned
 325    and a <gdb:exception> object is stored in *EXCP.  */
 326
 327 const struct block *
 328 bkscm_scm_to_block (SCM block_scm, int arg_pos, const char *func_name,
 329                     SCM *excp)
 330 {
 331   block_smob *b_smob;
 332
 333   b_smob = bkscm_get_valid_block (block_scm, arg_pos, func_name, excp);
 334
 335   if (b_smob != NULL)
 336     return b_smob->block;
 337   return NULL;
 338 }
 339
 340 /* Helper function for bkscm_del_objfile_blocks to mark the block
 341    as invalid.  */
 342
 343 static int
 344 bkscm_mark_block_invalid (void **slot, void *info)
 345 {
 346   block_smob *b_smob = (block_smob *) *slot;
 347
 348   b_smob->block = NULL;
 349   b_smob->objfile = NULL;
 350   return 1;
 351 }
 352
 353 /* This function is called when an objfile is about to be freed.
 354    Invalidate the block as further actions on the block would result
 355    in bad data.  All access to b_smob->block should be gated by
 356    checks to ensure the block is (still) valid.  */
 357
 358 static void
 359 bkscm_del_objfile_blocks (struct objfile *objfile, void *datum)
 360 {
 361   htab_t htab = datum;
 362
 363   if (htab != NULL)
 364     {
 365       htab_traverse_noresize (htab, bkscm_mark_block_invalid, NULL);
 366       htab_delete (htab);
 367     }
 368 }
 369 \f
 370 /* Block methods.  */
 371
 372 /* (block-valid? <gdb:block>) -> boolean
 373    Returns #t if SELF still exists in GDB.  */
 374
 375 static SCM
 376 gdbscm_block_valid_p (SCM self)
 377 {
 378   block_smob *b_smob
 379     = bkscm_get_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 380
 381   return scm_from_bool (bkscm_is_valid (b_smob));
 382 }
 383
 384 /* (block-start <gdb:block>) -> address */
 385
 386 static SCM
 387 gdbscm_block_start (SCM self)
 388 {
 389   block_smob *b_smob
 390     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 391   const struct block *block = b_smob->block;
 392
 393   return gdbscm_scm_from_ulongest (BLOCK_START (block));
 394 }
 395
 396 /* (block-end <gdb:block>) -> address */
 397
 398 static SCM
 399 gdbscm_block_end (SCM self)
 400 {
 401   block_smob *b_smob
 402     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 403   const struct block *block = b_smob->block;
 404
 405   return gdbscm_scm_from_ulongest (BLOCK_END (block));
 406 }
 407
 408 /* (block-function <gdb:block>) -> <gdb:symbol> */
 409
 410 static SCM
 411 gdbscm_block_function (SCM self)
 412 {
 413   block_smob *b_smob
 414     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 415   const struct block *block = b_smob->block;
 416   struct symbol *sym;
 417
 418   sym = BLOCK_FUNCTION (block);
 419
 420   if (sym != NULL)
 421     return syscm_scm_from_symbol (sym);
 422   return SCM_BOOL_F;
 423 }
 424
 425 /* (block-superblock <gdb:block>) -> <gdb:block> */
 426
 427 static SCM
 428 gdbscm_block_superblock (SCM self)
 429 {
 430   block_smob *b_smob
 431     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 432   const struct block *block = b_smob->block;
 433   const struct block *super_block;
 434
 435   super_block = BLOCK_SUPERBLOCK (block);
 436
 437   if (super_block)
 438     return bkscm_scm_from_block (super_block, b_smob->objfile);
 439   return SCM_BOOL_F;
 440 }
 441
 442 /* (block-global-block <gdb:block>) -> <gdb:block>
 443    Returns the global block associated to this block.  */
 444
 445 static SCM
 446 gdbscm_block_global_block (SCM self)
 447 {
 448   block_smob *b_smob
 449     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 450   const struct block *block = b_smob->block;
 451   const struct block *global_block;
 452
 453   global_block = block_global_block (block);
 454
 455   return bkscm_scm_from_block (global_block, b_smob->objfile);
 456 }
 457
 458 /* (block-static-block <gdb:block>) -> <gdb:block>
 459    Returns the static block associated to this block.
 460    Returns #f if we cannot get the static block (this is the global block).  */
 461
 462 static SCM
 463 gdbscm_block_static_block (SCM self)
 464 {
 465   block_smob *b_smob
 466     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 467   const struct block *block = b_smob->block;
 468   const struct block *static_block;
 469
 470   if (BLOCK_SUPERBLOCK (block) == NULL)
 471     return SCM_BOOL_F;
 472
 473   static_block = block_static_block (block);
 474
 475   return bkscm_scm_from_block (static_block, b_smob->objfile);
 476 }
 477
 478 /* (block-global? <gdb:block>) -> boolean
 479    Returns #t if this block object is a global block.  */
 480
 481 static SCM
 482 gdbscm_block_global_p (SCM self)
 483 {
 484   block_smob *b_smob
 485     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 486   const struct block *block = b_smob->block;
 487
 488   return scm_from_bool (BLOCK_SUPERBLOCK (block) == NULL);
 489 }
 490
 491 /* (block-static? <gdb:block>) -> boolean
 492    Returns #t if this block object is a static block.  */
 493
 494 static SCM
 495 gdbscm_block_static_p (SCM self)
 496 {
 497   block_smob *b_smob
 498     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 499   const struct block *block = b_smob->block;
 500
 501   if (BLOCK_SUPERBLOCK (block) != NULL
 502       && BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (block)) == NULL)
 503     return SCM_BOOL_T;
 504   return SCM_BOOL_F;
 505 }
 506
 507 /* (block-symbols <gdb:block>) -> list of <gdb:symbol objects
 508    Returns a list of symbols of the block.  */
 509
 510 static SCM
 511 gdbscm_block_symbols (SCM self)
 512 {
 513   block_smob *b_smob
 514     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 515   const struct block *block = b_smob->block;
 516   struct block_iterator iter;
 517   struct symbol *sym;
 518   SCM result;
 519
 520   result = SCM_EOL;
 521
 522   sym = block_iterator_first (block, &iter);
 523
 524   while (sym != NULL)
 525     {
 526       SCM s_scm = syscm_scm_from_symbol (sym);
 527
 528       result = scm_cons (s_scm, result);
 529       sym = block_iterator_next (&iter);
 530     }
 531
 532   return scm_reverse_x (result, SCM_EOL);
 533 }
 534 \f
 535 /* The <gdb:block-symbols-iterator> object,
 536    for iterating over all symbols in a block.  */
 537
 538 /* The smob "mark" function for <gdb:block-symbols-iterator>.  */
 539
 540 static SCM
 541 bkscm_mark_block_syms_progress_smob (SCM self)
 542 {
 543   block_syms_progress_smob *i_smob
 544     = (block_syms_progress_smob *) SCM_SMOB_DATA (self);
 545
 546   /* Do this last.  */
 547   return gdbscm_mark_gsmob (&i_smob->base);
 548 }
 549
 550 /* The smob "print" function for <gdb:block-symbols-iterator>.  */
 551
 552 static int
 553 bkscm_print_block_syms_progress_smob (SCM self, SCM port,
 554                                       scm_print_state *pstate)
 555 {
 556   block_syms_progress_smob *i_smob
 557     = (block_syms_progress_smob *) SCM_SMOB_DATA (self);
 558
 559   gdbscm_printf (port, "#<%s", block_syms_progress_smob_name);
 560
 561   if (i_smob->initialized_p)
 562     {
 563       switch (i_smob->iter.which)
 564         {
 565         case GLOBAL_BLOCK:
 566         case STATIC_BLOCK:
 567           {
 568             struct symtab *s;
 569
 570             gdbscm_printf (port, " %s",
 571                            i_smob->iter.which == GLOBAL_BLOCK
 572                            ? "global" : "static");
 573             if (i_smob->iter.idx != -1)
 574               gdbscm_printf (port, " @%d", i_smob->iter.idx);
 575             s = (i_smob->iter.idx == -1
 576                  ? i_smob->iter.d.symtab
 577                  : i_smob->iter.d.symtab->includes[i_smob->iter.idx]);
 578             gdbscm_printf (port, " %s", symtab_to_filename_for_display (s));
 579             break;
 580           }
 581         case FIRST_LOCAL_BLOCK:
 582           gdbscm_printf (port, " single block");
 583           break;
 584         }
 585     }
 586   else
 587     gdbscm_printf (port, " !initialized");
 588
 589   scm_puts (">", port);
 590
 591   scm_remember_upto_here_1 (self);
 592
 593   /* Non-zero means success.  */
 594   return 1;
 595 }
 596
 597 /* Low level routine to create a <gdb:block-symbols-progress> object.  */
 598
 599 static SCM
 600 bkscm_make_block_syms_progress_smob (void)
 601 {
 602   block_syms_progress_smob *i_smob = (block_syms_progress_smob *)
 603     scm_gc_malloc (sizeof (block_syms_progress_smob),
 604                    block_syms_progress_smob_name);
 605   SCM smob;
 606
 607   memset (&i_smob->iter, 0, sizeof (i_smob->iter));
 608   i_smob->initialized_p = 0;
 609   smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob);
 610   gdbscm_init_gsmob (&i_smob->base);
 611
 612   return smob;
 613 }
 614
 615 /* Returns non-zero if SCM is a <gdb:block-symbols-progress> object.  */
 616
 617 static int
 618 bkscm_is_block_syms_progress (SCM scm)
 619 {
 620   return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm);
 621 }
 622
 623 /* (block-symbols-progress? scm) -> boolean */
 624
 625 static SCM
 626 bkscm_block_syms_progress_p (SCM scm)
 627 {
 628   return scm_from_bool (bkscm_is_block_syms_progress (scm));
 629 }
 630
 631 /* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator>
 632    Return a <gdb:iterator> object for iterating over the symbols of SELF.  */
 633
 634 static SCM
 635 gdbscm_make_block_syms_iter (SCM self)
 636 {
 637   block_smob *b_smob
 638     = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 639   const struct block *block = b_smob->block;
 640   SCM progress, iter;
 641
 642   progress = bkscm_make_block_syms_progress_smob ();
 643
 644   iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc);
 645
 646   return iter;
 647 }
 648
 649 /* Returns the next symbol in the iteration through the block's dictionary,
 650    or (end-of-iteration).
 651    This is the iterator_smob.next_x method.  */
 652
 653 static SCM
 654 gdbscm_block_next_symbol_x (SCM self)
 655 {
 656   SCM progress, iter_scm, block_scm;
 657   iterator_smob *iter_smob;
 658   block_smob *b_smob;
 659   const struct block *block;
 660   block_syms_progress_smob *p_smob;
 661   struct symbol *sym;
 662
 663   iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 664   iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm);
 665
 666   block_scm = itscm_iterator_smob_object (iter_smob);
 667   b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm,
 668                                                   SCM_ARG1, FUNC_NAME);
 669   block = b_smob->block;
 670
 671   progress = itscm_iterator_smob_progress (iter_smob);
 672
 673   SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress),
 674                    progress, SCM_ARG1, FUNC_NAME,
 675                    block_syms_progress_smob_name);
 676   p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress);
 677
 678   if (!p_smob->initialized_p)
 679     {
 680       sym = block_iterator_first (block, &p_smob->iter);
 681       p_smob->initialized_p = 1;
 682     }
 683   else
 684     sym = block_iterator_next (&p_smob->iter);
 685
 686   if (sym == NULL)
 687     return gdbscm_end_of_iteration ();
 688
 689   return syscm_scm_from_symbol (sym);
 690 }
 691 \f
 692 /* (lookup-block address) -> <gdb:block>
 693    Returns the innermost lexical block containing the specified pc value,
 694    or #f if there is none.  */
 695
 696 static SCM
 697 gdbscm_lookup_block (SCM pc_scm)
 698 {
 699   CORE_ADDR pc;
 700   struct block *block = NULL;
 701   struct obj_section *section = NULL;
 702   struct symtab *symtab = NULL;
 703   volatile struct gdb_exception except;
 704
 705   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc);
 706
 707   TRY_CATCH (except, RETURN_MASK_ALL)
 708     {
 709       section = find_pc_mapped_section (pc);
 710       symtab = find_pc_sect_symtab (pc, section);
 711
 712       if (symtab != NULL && symtab->objfile != NULL)
 713         block = block_for_pc (pc);
 714     }
 715   GDBSCM_HANDLE_GDB_EXCEPTION (except);
 716
 717   if (symtab == NULL || symtab->objfile == NULL)
 718     {
 719       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm,
 720                                  _("cannot locate object file for block"));
 721     }
 722
 723   if (block != NULL)
 724     return bkscm_scm_from_block (block, symtab->objfile);
 725   return SCM_BOOL_F;
 726 }
 727 \f
 728 /* Initialize the Scheme block support.  */
 729
 730 static const scheme_function block_functions[] =
 731 {
 732   { "block?", 1, 0, 0, gdbscm_block_p,
 733     "\
 734 Return #t if the object is a <gdb:block> object." },
 735
 736   { "block-valid?", 1, 0, 0, gdbscm_block_valid_p,
 737     "\
 738 Return #t if the block is valid.\n\
 739 A block becomes invalid when its objfile is freed." },
 740
 741   { "block-start", 1, 0, 0, gdbscm_block_start,
 742     "\
 743 Return the start address of the block." },
 744
 745   { "block-end", 1, 0, 0, gdbscm_block_end,
 746     "\
 747 Return the end address of the block." },
 748
 749   { "block-function", 1, 0, 0, gdbscm_block_function,
 750     "\
 751 Return the gdb:symbol object of the function containing the block\n\
 752 or #f if the block does not live in any function." },
 753
 754   { "block-superblock", 1, 0, 0, gdbscm_block_superblock,
 755     "\
 756 Return the superblock (parent block) of the block." },
 757
 758   { "block-global-block", 1, 0, 0, gdbscm_block_global_block,
 759     "\
 760 Return the global block of the block." },
 761
 762   { "block-static-block", 1, 0, 0, gdbscm_block_static_block,
 763     "\
 764 Return the static block of the block." },
 765
 766   { "block-global?", 1, 0, 0, gdbscm_block_global_p,
 767     "\
 768 Return #t if block is a global block." },
 769
 770   { "block-static?", 1, 0, 0, gdbscm_block_static_p,
 771     "\
 772 Return #t if block is a static block." },
 773
 774   { "block-symbols", 1, 0, 0, gdbscm_block_symbols,
 775     "\
 776 Return a list of all symbols (as <gdb:symbol> objects) in the block." },
 777
 778   { "make-block-symbols-iterator", 1, 0, 0, gdbscm_make_block_syms_iter,
 779     "\
 780 Return a <gdb:iterator> object for iterating over all symbols in the block." },
 781
 782   { "block-symbols-progress?", 1, 0, 0, bkscm_block_syms_progress_p,
 783     "\
 784 Return #t if the object is a <gdb:block-symbols-progress> object." },
 785
 786   { "lookup-block", 1, 0, 0, gdbscm_lookup_block,
 787     "\
 788 Return the innermost GDB block containing the address or #f if none found.\n\
 789 \n\
 790   Arguments:\n\
 791     address: the address to lookup" },
 792
 793   END_FUNCTIONS
 794 };
 795
 796 void
 797 gdbscm_initialize_blocks (void)
 798 {
 799   block_smob_tag
 800     = gdbscm_make_smob_type (block_smob_name, sizeof (block_smob));
 801   scm_set_smob_mark (block_smob_tag, bkscm_mark_block_smob);
 802   scm_set_smob_free (block_smob_tag, bkscm_free_block_smob);
 803   scm_set_smob_print (block_smob_tag, bkscm_print_block_smob);
 804
 805   block_syms_progress_smob_tag
 806     = gdbscm_make_smob_type (block_syms_progress_smob_name,
 807                              sizeof (block_syms_progress_smob));
 808   scm_set_smob_mark (block_syms_progress_smob_tag,
 809                      bkscm_mark_block_syms_progress_smob);
 810   scm_set_smob_print (block_syms_progress_smob_tag,
 811                       bkscm_print_block_syms_progress_smob);
 812
 813   gdbscm_define_functions (block_functions, 1);
 814
 815   /* This function is "private".  */
 816   bkscm_next_symbol_x_proc
 817     = scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0,
 818                           gdbscm_block_next_symbol_x);
 819   scm_set_procedure_property_x (bkscm_next_symbol_x_proc,
 820                                 gdbscm_documentation_symbol,
 821                                 gdbscm_scm_from_c_string ("\
 822 Internal function to assist the block symbols iterator."));
 823
 824   /* Register an objfile "free" callback so we can properly
 825      invalidate blocks when an object file is about to be deleted.  */
 826   bkscm_objfile_data_key
 827     = register_objfile_data_with_cleanup (NULL, bkscm_del_objfile_blocks);
 828 }