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