gdb/guile/scm-block.c

   1 /* Scheme interface to blocks.
   2
   3    Copyright (C) 2008-2024 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 ();
 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 ();
 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   SCM result;
 505
 506   result = SCM_EOL;
 507
 508   for (struct symbol *sym : block_iterator_range (block))
 509     {
 510       SCM s_scm = syscm_scm_from_symbol (sym);
 511
 512       result = scm_cons (s_scm, result);
 513     }
 514
 515   return scm_reverse_x (result, SCM_EOL);
 516 }
 517 \f
 518 /* The <gdb:block-symbols-iterator> object,
 519    for iterating over all symbols in a block.  */
 520
 521 /* The smob "print" function for <gdb:block-symbols-iterator>.  */
 522
 523 static int
 524 bkscm_print_block_syms_progress_smob (SCM self, SCM port,
 525                                       scm_print_state *pstate)
 526 {
 527   block_syms_progress_smob *i_smob
 528     = (block_syms_progress_smob *) SCM_SMOB_DATA (self);
 529
 530   gdbscm_printf (port, "#<%s", block_syms_progress_smob_name);
 531
 532   if (i_smob->initialized_p)
 533     {
 534       switch (i_smob->iter.which)
 535         {
 536         case GLOBAL_BLOCK:
 537         case STATIC_BLOCK:
 538           {
 539             struct compunit_symtab *cust;
 540
 541             gdbscm_printf (port, " %s",
 542                            i_smob->iter.which == GLOBAL_BLOCK
 543                            ? "global" : "static");
 544             if (i_smob->iter.idx != -1)
 545               gdbscm_printf (port, " @%d", i_smob->iter.idx);
 546             cust = (i_smob->iter.idx == -1
 547                     ? i_smob->iter.d.compunit_symtab
 548                     : i_smob->iter.d.compunit_symtab->includes[i_smob->iter.idx]);
 549             gdbscm_printf (port, " %s",
 550                            symtab_to_filename_for_display
 551                              (cust->primary_filetab ()));
 552             break;
 553           }
 554         case FIRST_LOCAL_BLOCK:
 555           gdbscm_printf (port, " single block");
 556           break;
 557         }
 558     }
 559   else
 560     gdbscm_printf (port, " !initialized");
 561
 562   scm_puts (">", port);
 563
 564   scm_remember_upto_here_1 (self);
 565
 566   /* Non-zero means success.  */
 567   return 1;
 568 }
 569
 570 /* Low level routine to create a <gdb:block-symbols-progress> object.  */
 571
 572 static SCM
 573 bkscm_make_block_syms_progress_smob (void)
 574 {
 575   block_syms_progress_smob *i_smob = (block_syms_progress_smob *)
 576     scm_gc_malloc (sizeof (block_syms_progress_smob),
 577                    block_syms_progress_smob_name);
 578   SCM smob;
 579
 580   memset (&i_smob->iter, 0, sizeof (i_smob->iter));
 581   i_smob->initialized_p = 0;
 582   smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob);
 583   gdbscm_init_gsmob (&i_smob->base);
 584
 585   return smob;
 586 }
 587
 588 /* Returns non-zero if SCM is a <gdb:block-symbols-progress> object.  */
 589
 590 static int
 591 bkscm_is_block_syms_progress (SCM scm)
 592 {
 593   return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm);
 594 }
 595
 596 /* (block-symbols-progress? scm) -> boolean */
 597
 598 static SCM
 599 bkscm_block_syms_progress_p (SCM scm)
 600 {
 601   return scm_from_bool (bkscm_is_block_syms_progress (scm));
 602 }
 603
 604 /* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator>
 605    Return a <gdb:iterator> object for iterating over the symbols of SELF.  */
 606
 607 static SCM
 608 gdbscm_make_block_syms_iter (SCM self)
 609 {
 610   /* Call for side effects.  */
 611   bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 612   SCM progress, iter;
 613
 614   progress = bkscm_make_block_syms_progress_smob ();
 615
 616   iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc);
 617
 618   return iter;
 619 }
 620
 621 /* Returns the next symbol in the iteration through the block's dictionary,
 622    or (end-of-iteration).
 623    This is the iterator_smob.next_x method.  */
 624
 625 static SCM
 626 gdbscm_block_next_symbol_x (SCM self)
 627 {
 628   SCM progress, iter_scm, block_scm;
 629   iterator_smob *iter_smob;
 630   block_smob *b_smob;
 631   const struct block *block;
 632   block_syms_progress_smob *p_smob;
 633   struct symbol *sym;
 634
 635   iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
 636   iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm);
 637
 638   block_scm = itscm_iterator_smob_object (iter_smob);
 639   b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm,
 640                                                   SCM_ARG1, FUNC_NAME);
 641   block = b_smob->block;
 642
 643   progress = itscm_iterator_smob_progress (iter_smob);
 644
 645   SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress),
 646                    progress, SCM_ARG1, FUNC_NAME,
 647                    block_syms_progress_smob_name);
 648   p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress);
 649
 650   if (!p_smob->initialized_p)
 651     {
 652       sym = block_iterator_first (block, &p_smob->iter);
 653       p_smob->initialized_p = 1;
 654     }
 655   else
 656     sym = block_iterator_next (&p_smob->iter);
 657
 658   if (sym == NULL)
 659     return gdbscm_end_of_iteration ();
 660
 661   return syscm_scm_from_symbol (sym);
 662 }
 663 \f
 664 /* (lookup-block address) -> <gdb:block>
 665    Returns the innermost lexical block containing the specified pc value,
 666    or #f if there is none.  */
 667
 668 static SCM
 669 gdbscm_lookup_block (SCM pc_scm)
 670 {
 671   CORE_ADDR pc;
 672   const struct block *block = NULL;
 673   struct compunit_symtab *cust = NULL;
 674
 675   gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc);
 676
 677   gdbscm_gdb_exception exc {};
 678   try
 679     {
 680       cust = find_pc_compunit_symtab (pc);
 681
 682       if (cust != NULL && cust->objfile () != NULL)
 683         block = block_for_pc (pc);
 684     }
 685   catch (const gdb_exception &except)
 686     {
 687       exc = unpack (except);
 688     }
 689
 690   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 691   if (cust == NULL || cust->objfile () == NULL)
 692     {
 693       gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm,
 694                                  _("cannot locate object file for block"));
 695     }
 696
 697   if (block != NULL)
 698     return bkscm_scm_from_block (block, cust->objfile ());
 699   return SCM_BOOL_F;
 700 }
 701 \f
 702 /* Initialize the Scheme block support.  */
 703
 704 static const scheme_function block_functions[] =
 705 {
 706   { "block?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_p),
 707     "\
 708 Return #t if the object is a <gdb:block> object." },
 709
 710   { "block-valid?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_valid_p),
 711     "\
 712 Return #t if the block is valid.\n\
 713 A block becomes invalid when its objfile is freed." },
 714
 715   { "block-start", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_start),
 716     "\
 717 Return the start address of the block." },
 718
 719   { "block-end", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_end),
 720     "\
 721 Return the end address of the block." },
 722
 723   { "block-function", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_function),
 724     "\
 725 Return the gdb:symbol object of the function containing the block\n\
 726 or #f if the block does not live in any function." },
 727
 728   { "block-superblock", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_superblock),
 729     "\
 730 Return the superblock (parent block) of the block." },
 731
 732   { "block-global-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_block),
 733     "\
 734 Return the global block of the block." },
 735
 736   { "block-static-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_block),
 737     "\
 738 Return the static block of the block." },
 739
 740   { "block-global?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_global_p),
 741     "\
 742 Return #t if block is a global block." },
 743
 744   { "block-static?", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_static_p),
 745     "\
 746 Return #t if block is a static block." },
 747
 748   { "block-symbols", 1, 0, 0, as_a_scm_t_subr (gdbscm_block_symbols),
 749     "\
 750 Return a list of all symbols (as <gdb:symbol> objects) in the block." },
 751
 752   { "make-block-symbols-iterator", 1, 0, 0,
 753     as_a_scm_t_subr (gdbscm_make_block_syms_iter),
 754     "\
 755 Return a <gdb:iterator> object for iterating over all symbols in the block." },
 756
 757   { "block-symbols-progress?", 1, 0, 0,
 758     as_a_scm_t_subr (bkscm_block_syms_progress_p),
 759     "\
 760 Return #t if the object is a <gdb:block-symbols-progress> object." },
 761
 762   { "lookup-block", 1, 0, 0, as_a_scm_t_subr (gdbscm_lookup_block),
 763     "\
 764 Return the innermost GDB block containing the address or #f if none found.\n\
 765 \n\
 766   Arguments:\n\
 767     address: the address to lookup" },
 768
 769   END_FUNCTIONS
 770 };
 771
 772 void
 773 gdbscm_initialize_blocks (void)
 774 {
 775   block_smob_tag
 776     = gdbscm_make_smob_type (block_smob_name, sizeof (block_smob));
 777   scm_set_smob_free (block_smob_tag, bkscm_free_block_smob);
 778   scm_set_smob_print (block_smob_tag, bkscm_print_block_smob);
 779
 780   block_syms_progress_smob_tag
 781     = gdbscm_make_smob_type (block_syms_progress_smob_name,
 782                              sizeof (block_syms_progress_smob));
 783   scm_set_smob_print (block_syms_progress_smob_tag,
 784                       bkscm_print_block_syms_progress_smob);
 785
 786   gdbscm_define_functions (block_functions, 1);
 787
 788   /* This function is "private".  */
 789   bkscm_next_symbol_x_proc
 790     = scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0,
 791                           as_a_scm_t_subr (gdbscm_block_next_symbol_x));
 792   scm_set_procedure_property_x (bkscm_next_symbol_x_proc,
 793                                 gdbscm_documentation_symbol,
 794                                 gdbscm_scm_from_c_string ("\
 795 Internal function to assist the block symbols iterator."));
 796 }