gdb/guile/scm-block.c

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