gdb/guile/scm-block.c

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