[PATCH v1 19/36] Guile extension language: scm-block.c

[Doug Evans <xdje42 at gmail dot com>]

This patch adds the interface to gdb blocks.

2013-12-24  Doug Evans  <xdje42@gmail.com>

	* guile/scm-block.c: New file.

	testsuite/
	* gdb.guile/scm-block.c: New file.
	* gdb.guile/scm-block.exp: New file.

diff --git a/gdb/guile/scm-block.c b/gdb/guile/scm-block.c
new file mode 100644
index 0000000..65d42e3
--- /dev/null
+++ b/gdb/guile/scm-block.c
@@ -0,0 +1,878 @@
+/* Scheme interface to blocks.
+
+   Copyright (C) 2008-2013 Free Software Foundation, Inc.
+
+   This file is part of GDB.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+
+/* See README file in this directory for implementation notes, coding
+   conventions, et.al.  */
+
+#include "defs.h"
+#include "block.h"
+#include "dictionary.h"
+#include "objfiles.h"
+#include "source.h"
+#include "symtab.h"
+#include "guile-internal.h"
+
+/* A smob describing a gdb block.  */
+
+typedef struct _block_smob
+{
+  /* This always appears first.
+     We want blocks to be eq?-able.  And we need to be able to invalidate
+     blocks when the associated objfile is deleted.  */
+  eqable_gdb_smob base;
+
+  /* The GDB block structure that represents a frame's code block.  */
+  const struct block *block;
+
+  /* The backing object file.  There is no direct relationship in GDB
+     between a block and an object file.  When a block is created also
+     store a pointer to the object file for later use.  */
+  struct objfile *objfile;
+} block_smob;
+
+/* To iterate over block symbols from Scheme we need to store
+   struct block_iterator somewhere.  This is stored in the "progress" field
+   of <gdb:iterator>.  We store the block object in iterator_smob.object,
+   so we don't store it here.
+
+   Remember: While iterating over block symbols, you must continually check
+   whether the block is still valid.  */
+
+typedef struct
+{
+  /* This always appears first.  */
+  gdb_smob base;
+
+  /* The iterator for that block.  */
+  struct block_iterator iter;
+
+  /* Has the iterator been initialized flag.  */
+  int initialized_p;
+} block_syms_progress_smob;
+
+static const char block_smob_name[] = "gdb:block";
+static const char block_syms_progress_smob_name[] = "gdb:block-symbols-iterator";
+
+/* The tag Guile knows the block smobs by.  */
+static scm_t_bits block_smob_tag;
+static scm_t_bits block_syms_progress_smob_tag;
+
+/* The "next!" block syms iterator method.  */
+static SCM bkscm_next_symbol_x_proc;
+
+static const struct objfile_data *bkscm_objfile_data_key;
+
+/* Administrivia for block smobs.  */
+
+/* Helper function to hash a block_smob.  */
+
+static hashval_t
+bkscm_hash_block_smob (const void *p)
+{
+  const block_smob *b_smob = p;
+
+  return htab_hash_pointer (b_smob->block);
+}
+
+/* Helper function to compute equality of block_smobs.  */
+
+static int
+bkscm_eq_block_smob (const void *ap, const void *bp)
+{
+  const block_smob *a = ap;
+  const block_smob *b = bp;
+
+  return (a->block == b->block
+	  && a->block != NULL);
+}
+
+/* Return the struct block pointer -> SCM mapping table.
+   It is created if necessary.  */
+
+static htab_t
+bkscm_objfile_block_map (struct objfile *objfile)
+{
+  htab_t htab = objfile_data (objfile, bkscm_objfile_data_key);
+
+  if (htab == NULL)
+    {
+      htab = gdbscm_create_eqable_gsmob_ptr_map (bkscm_hash_block_smob,
+						 bkscm_eq_block_smob);
+      set_objfile_data (objfile, bkscm_objfile_data_key, htab);
+    }
+
+  return htab;
+}
+
+/* The smob "mark" function for <gdb:block>.  */
+
+static SCM
+bkscm_mark_block_smob (SCM self)
+{
+  block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
+
+  /* Do this last.  */
+  return gdbscm_mark_eqable_gsmob (&b_smob->base);
+}
+
+/* The smob "free" function for <gdb:block>.  */
+
+static size_t
+bkscm_free_block_smob (SCM self)
+{
+  block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
+
+  if (b_smob->block != NULL)
+    {
+      htab_t htab = bkscm_objfile_block_map (b_smob->objfile);
+
+      gdbscm_clear_eqable_gsmob_ptr_slot (htab, &b_smob->base);
+    }
+
+  /* Not necessary, done to catch bugs.  */
+  b_smob->block = NULL;
+  b_smob->objfile = NULL;
+
+  return 0;
+}
+
+/* The smob "print" function for <gdb:block>.  */
+
+static int
+bkscm_print_block_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+  block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
+  const struct block *b = b_smob->block;
+
+  gdbscm_printf (port, "#<%s", block_smob_name);
+
+  if (BLOCK_SUPERBLOCK (b) == NULL)
+    gdbscm_printf (port, " global");
+  else if (BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (b)) == NULL)
+    gdbscm_printf (port, " static");
+
+  if (BLOCK_FUNCTION (b) != NULL)
+    gdbscm_printf (port, " %s", SYMBOL_PRINT_NAME (BLOCK_FUNCTION (b)));
+
+  gdbscm_printf (port, " %s-%s",
+		 hex_string (BLOCK_START (b)), hex_string (BLOCK_END (b)));
+
+  scm_puts (">", port);
+
+  scm_remember_upto_here_1 (self);
+
+  /* Non-zero means success.  */
+  return 1;
+}
+
+/* Low level routine to create a <gdb:block> object.  */
+
+static SCM
+bkscm_make_block_smob (void)
+{
+  block_smob *b_smob = (block_smob *)
+    scm_gc_malloc (sizeof (block_smob), block_smob_name);
+  SCM b_scm;
+
+  b_smob->block = NULL;
+  b_smob->objfile = NULL;
+  b_scm = scm_new_smob (block_smob_tag, (scm_t_bits) b_smob);
+  gdbscm_init_eqable_gsmob (&b_smob->base);
+
+  return b_scm;
+}
+
+/* Returns non-zero if SCM is a <gdb:block> object.  */
+
+static int
+bkscm_is_block (SCM scm)
+{
+  return SCM_SMOB_PREDICATE (block_smob_tag, scm);
+}
+
+/* (block? scm) -> boolean */
+
+static SCM
+gdbscm_block_p (SCM scm)
+{
+  return scm_from_bool (bkscm_is_block (scm));
+}
+
+/* Returns a new <gdb:block> object that encapsulates BLOCK.  */
+
+static SCM
+bkscm_gsmob_from_block (const struct block *block, struct objfile *objfile)
+{
+  SCM smob;
+  block_smob *b_smob;
+
+  smob = bkscm_make_block_smob ();
+  b_smob = (block_smob *) SCM_SMOB_DATA (smob);
+  b_smob->block = block;
+  b_smob->objfile = objfile;
+
+  return smob;
+}
+
+/* Return the existing object that encapsulates BLOCK, or create a new
+   <gdb:block> object.
+   If the object is created it is passed through *smob->scm*.
+   A Scheme exception is thrown if there is an error.  */
+
+SCM
+bkscm_scm_from_block_unsafe (const struct block *block,
+			     struct objfile *objfile)
+{
+  htab_t htab;
+  eqable_gdb_smob **slot;
+  block_smob *b_smob, b_smob_for_lookup;
+  SCM b_scm, result;
+
+  /* If we've already created a gsmob for this block, return it.
+     This makes blocks eq?-able.  */
+  htab = bkscm_objfile_block_map (objfile);
+  b_smob_for_lookup.block = block;
+  slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &b_smob_for_lookup.base);
+  if (*slot != NULL)
+    return (*slot)->containing_scm;
+
+  b_scm = bkscm_gsmob_from_block (block, objfile);
+  b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
+  result = gdbscm_scm_from_gsmob_unsafe (b_scm);
+  gdbscm_fill_eqable_gsmob_ptr_slot (slot, &b_smob->base, result);
+
+  return result;
+}
+
+/* Returns the <gdb:block> object in SCM or #f if SCM is not a
+   <gdb:block> object.
+   Returns a <gdb:exception> object if there was a problem during the
+   conversion.  */
+
+static SCM
+bkscm_scm_to_block_gsmob (SCM scm)
+{
+  return gdbscm_scm_to_gsmob_safe (scm, block_smob_tag);
+}
+
+/* Returns the <gdb:block> object in SELF.
+   Throws an exception if SELF is not a <gdb:block> object
+   (after passing it through *scm->smob*).  */
+
+static SCM
+bkscm_get_block_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+  SCM b_scm = bkscm_scm_to_block_gsmob (self);
+
+  if (gdbscm_is_exception (b_scm))
+    gdbscm_throw (b_scm);
+
+  SCM_ASSERT_TYPE (bkscm_is_block (b_scm), self, arg_pos, func_name,
+		   block_smob_name);
+
+  return b_scm;
+}
+
+/* Returns a pointer to the block smob of SELF.
+   Throws an exception if SELF is not a <gdb:block> object
+   (after passing it through *scm->smob*).  */
+
+static block_smob *
+bkscm_get_block_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+  SCM b_scm = bkscm_get_block_arg_unsafe (self, arg_pos, func_name);
+  block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
+
+  return b_smob;
+}
+
+/* Returns non-zero if block B_SMOB is valid.  */
+
+static int
+bkscm_is_valid (block_smob *b_smob)
+{
+  return b_smob->block != NULL;
+}
+
+/* Returns the block smob in SELF, verifying it's valid.
+   Throws an exception if SELF is not a <gdb:block> object or is invalid
+   (after passing it through *scm->smob*).  */
+
+static block_smob *
+bkscm_get_valid_block_smob_arg_unsafe (SCM self, int arg_pos,
+				       const char *func_name)
+{
+  block_smob *b_smob
+    = bkscm_get_block_smob_arg_unsafe (self, arg_pos, func_name);
+
+  if (!bkscm_is_valid (b_smob))
+    {
+      gdbscm_invalid_object_error (func_name, arg_pos, self,
+				   _("<gdb:block>"));
+    }
+
+  return b_smob;
+}
+
+/* Returns the block smob contained in SCM or NULL if SCM is not a
+   <gdb:block> object, or there's an error during the conversion.
+   If there is an error a <gdb:exception> object is stored in *EXCP.  */
+
+static block_smob *
+bkscm_get_valid_block (SCM scm, int arg_pos, const char *func_name, SCM *excp)
+{
+  block_smob *b_smob;
+  SCM b_scm;
+
+  if (bkscm_is_block (scm))
+    b_scm = scm;
+  else
+    {
+      b_scm = gdbscm_scm_to_gsmob_safe (scm, block_smob_tag);
+      if (gdbscm_is_exception (b_scm))
+	{
+	  *excp = b_scm;
+	  return NULL;
+	}
+      if (!bkscm_is_block (b_scm))
+	{
+	  *excp = gdbscm_make_type_error (func_name, arg_pos, scm,
+					  block_smob_name);
+	  return NULL;
+	}
+    }
+
+  b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
+  if (!bkscm_is_valid (b_smob))
+    {
+      *excp = gdbscm_make_invalid_object_error (func_name, arg_pos, scm,
+						_("<gdb:block>"));
+      return NULL;
+    }
+
+  return b_smob;
+}
+
+/* Returns the struct block that is wrapped by BLOCK_SCM.
+   If BLOCK_SCM is not a block, or is an invalid block, or an error happens
+   during the conversion NULL is returned and a <gdb:exception> object is
+   stored in *EXCP.  */
+
+const struct block *
+bkscm_scm_to_block (SCM block_scm, int arg_pos, const char *func_name,
+		    SCM *excp)
+{
+  block_smob *b_smob;
+
+  b_smob = bkscm_get_valid_block (block_scm, arg_pos, func_name, excp);
+
+  if (b_smob != NULL)
+    return b_smob->block;
+  return NULL;
+}
+
+/* Helper function for bkscm_del_objfile_blocks to mark the block
+   as invalid.  */
+
+static int
+bkscm_mark_block_invalid (void **slot, void *info)
+{
+  block_smob *b_smob = (block_smob *) *slot;
+
+  b_smob->block = NULL;
+  b_smob->objfile = NULL;
+  return 1;
+}
+
+/* This function is called when an objfile is about to be freed.
+   Invalidate the block as further actions on the block would result
+   in bad data.  All access to b_smob->block should be gated by
+   checks to ensure the block is (still) valid.  */
+
+static void
+bkscm_del_objfile_blocks (struct objfile *objfile, void *datum)
+{
+  htab_t htab = datum;
+
+  if (htab != NULL)
+    {
+      htab_traverse_noresize (htab, bkscm_mark_block_invalid, NULL);
+      htab_delete (htab);
+    }
+}
+
+/* Block methods.  */
+
+/* (block-valid? <gdb:block>) -> boolean
+   Returns #t if SELF still exists in GDB.  */
+
+static SCM
+gdbscm_block_valid_p (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+  return scm_from_bool (bkscm_is_valid (b_smob));
+}
+
+/* (block-start <gdb:block>) -> address */
+
+static SCM
+gdbscm_block_start (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+
+  return gdbscm_scm_from_ulongest (BLOCK_START (block));
+}
+
+/* (block-end <gdb:block>) -> address */
+
+static SCM
+gdbscm_block_end (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+
+  return gdbscm_scm_from_ulongest (BLOCK_END (block));
+}
+
+/* (block-function <gdb:block>) -> <gdb:symbol> */
+
+static SCM
+gdbscm_block_function (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+  struct symbol *sym;
+
+  sym = BLOCK_FUNCTION (block);
+
+  if (sym)
+    return syscm_scm_from_symbol_unsafe (sym);
+  return SCM_BOOL_F;
+}
+
+/* (block-superblock <gdb:block>) -> <gdb:block> */
+
+static SCM
+gdbscm_block_superblock (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+  const struct block *super_block;
+
+  super_block = BLOCK_SUPERBLOCK (block);
+
+  if (super_block)
+    return bkscm_scm_from_block_unsafe (super_block, b_smob->objfile);
+  return SCM_BOOL_F;
+}
+
+/* (block-global-block <gdb:block>) -> <gdb:block>
+   Returns the global block associated to this block.  */
+
+static SCM
+gdbscm_block_global_block (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+  const struct block *global_block;
+
+  global_block = block_global_block (block);
+
+  return bkscm_scm_from_block_unsafe (global_block, b_smob->objfile);
+}
+
+/* (block-static-block <gdb:block>) -> <gdb:block>
+   Returns the static block associated to this block.
+   Returns #f if we cannot get the static block (this is the global block).  */
+
+static SCM
+gdbscm_block_static_block (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+  const struct block *static_block;
+
+  if (BLOCK_SUPERBLOCK (block) == NULL)
+    return SCM_BOOL_F;
+
+  static_block = block_static_block (block);
+
+  return bkscm_scm_from_block_unsafe (static_block, b_smob->objfile);
+}
+
+/* (block-global? <gdb:block>) -> boolean
+   Returns #t if this block object is a global block.  */
+
+static SCM
+gdbscm_block_global_p (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+
+  return scm_from_bool (BLOCK_SUPERBLOCK (block) == NULL);
+}
+
+/* (block-static? <gdb:block>) -> boolean
+   Returns #t if this block object is a static block.  */
+
+static SCM
+gdbscm_block_static_p (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+
+  if (BLOCK_SUPERBLOCK (block) != NULL
+      && BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (block)) == NULL)
+    return SCM_BOOL_T;
+  return SCM_BOOL_F;
+}
+
+/* (block-symbols <gdb:block>) -> list of <gdb:symbol objects
+   Returns a list of symbols of the block.  */
+
+static SCM
+gdbscm_block_symbols (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+  struct block_iterator iter;
+  struct symbol *sym;
+  SCM result;
+
+  result = SCM_EOL;
+
+  sym = block_iterator_first (block, &iter);
+
+  while (sym != NULL)
+    {
+      SCM s_scm = syscm_scm_from_symbol_unsafe (sym);
+
+      result = scm_cons (s_scm, result);
+      sym = block_iterator_next (&iter);
+    }
+
+  return scm_reverse_x (result, SCM_EOL);
+}
+
+/* The <gdb:block-symbols-iterator> object,
+   for iterating over all symbols in a block.  */
+
+/* The smob "mark" function for <gdb:block-symbols-iterator>.  */
+
+static SCM
+bkscm_mark_block_syms_progress_smob (SCM self)
+{
+  block_syms_progress_smob *i_smob
+    = (block_syms_progress_smob *) SCM_SMOB_DATA (self);
+
+  /* Do this last.  */
+  return gdbscm_mark_gsmob (&i_smob->base);
+}
+
+/* The smob "print" function for <gdb:block-symbols-iterator>.  */
+
+static int
+bkscm_print_block_syms_progress_smob (SCM self, SCM port,
+				      scm_print_state *pstate)
+{
+  block_syms_progress_smob *i_smob
+    = (block_syms_progress_smob *) SCM_SMOB_DATA (self);
+
+  gdbscm_printf (port, "#<%s", block_syms_progress_smob_name);
+
+  if (i_smob->initialized_p)
+    {
+      switch (i_smob->iter.which)
+	{
+	case GLOBAL_BLOCK:
+	case STATIC_BLOCK:
+	  {
+	    struct symtab *s;
+
+	    gdbscm_printf (port, " %s", 
+			   i_smob->iter.which == GLOBAL_BLOCK
+			   ? "global" : "static");
+	    if (i_smob->iter.idx != -1)
+	      gdbscm_printf (port, " @%d", i_smob->iter.idx);
+	    s = (i_smob->iter.idx == -1
+		 ? i_smob->iter.d.symtab
+		 : i_smob->iter.d.symtab->includes[i_smob->iter.idx]);
+	    gdbscm_printf (port, " %s", symtab_to_filename_for_display (s));
+	    break;
+	  }
+	case FIRST_LOCAL_BLOCK:
+	  gdbscm_printf (port, " single block");
+	  break;
+	}
+    }
+  else
+    gdbscm_printf (port, " !initialized");
+
+  scm_puts (">", port);
+
+  scm_remember_upto_here_1 (self);
+
+  /* Non-zero means success.  */
+  return 1;
+}
+
+/* Low level routine to create a <gdb:block-symbols-progress> object.  */
+
+static SCM
+bkscm_make_block_syms_progress_smob (void)
+{
+  block_syms_progress_smob *i_smob = (block_syms_progress_smob *)
+    scm_gc_malloc (sizeof (block_syms_progress_smob),
+		   block_syms_progress_smob_name);
+  SCM smob;
+
+  memset (&i_smob->iter, 0, sizeof (i_smob->iter));
+  i_smob->initialized_p = 0;
+  smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob);
+  gdbscm_init_gsmob (&i_smob->base);
+
+  return smob;
+}
+
+/* Returns non-zero if SCM is a <gdb:block-symbols-progress> object.  */
+
+static int
+bkscm_is_block_syms_progress (SCM scm)
+{
+  return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm);
+}
+
+/* (block-symbols-progress? scm) -> boolean */
+
+static SCM
+bkscm_block_syms_progress_p (SCM scm)
+{
+  return scm_from_bool (bkscm_is_block_syms_progress (scm));
+}
+
+/* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator>
+   Return a <gdb:iterator> object for iterating over the symbols of SELF.  */
+
+static SCM
+gdbscm_make_block_syms_iter (SCM self)
+{
+  block_smob *b_smob
+    = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct block *block = b_smob->block;
+  SCM progress, iter;
+
+  progress = bkscm_make_block_syms_progress_smob ();
+  progress = gdbscm_scm_from_gsmob_unsafe (progress);
+
+  iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc);
+
+  return gdbscm_scm_from_gsmob_unsafe (iter);
+}
+
+/* Returns the next symbol in the iteration through the block's dictionary.
+   This is the iterator_smob.next_x method.  */
+
+static SCM
+gdbscm_block_next_symbol_x (SCM self)
+{
+  SCM progress, iter_scm, block_scm;
+  iterator_smob *iter_smob;
+  block_smob *b_smob;
+  const struct block *block;
+  block_syms_progress_smob *p_smob;
+  struct symbol *sym;
+
+  iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm);
+
+  block_scm = itscm_iterator_smob_object (iter_smob);
+  b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm,
+						  SCM_ARG1, FUNC_NAME);
+  block = b_smob->block;
+
+  progress = itscm_iterator_smob_progress (iter_smob);
+
+  SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress),
+		   progress, SCM_ARG1, FUNC_NAME,
+		   block_syms_progress_smob_name);
+  p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress);
+
+  if (!p_smob->initialized_p)
+    {
+      sym = block_iterator_first (block, &p_smob->iter);
+      p_smob->initialized_p = 1;
+    }
+  else
+    sym = block_iterator_next (&p_smob->iter);
+
+  if (sym == NULL)
+    return SCM_BOOL_F;
+
+  return syscm_scm_from_symbol_unsafe (sym);
+}
+
+/* (lookup-block address) -> <gdb:block>
+   Returns the innermost lexical block containing the specified pc value,
+   or #f if there is none.  */
+
+static SCM
+gdbscm_lookup_block (SCM pc_scm)
+{
+  CORE_ADDR pc;
+  struct block *block = NULL;
+  struct obj_section *section = NULL;
+  struct symtab *symtab = NULL;
+  volatile struct gdb_exception except;
+
+  gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc);
+
+  TRY_CATCH (except, RETURN_MASK_ALL)
+    {
+      section = find_pc_mapped_section (pc);
+      symtab = find_pc_sect_symtab (pc, section);
+
+      if (symtab != NULL && symtab->objfile != NULL)
+	block = block_for_pc (pc);
+    }
+  GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+  if (symtab == NULL || symtab->objfile == NULL)
+    {
+      gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm,
+				 _("cannot locate object file for block"));
+    }
+
+  if (block != NULL)
+    return bkscm_scm_from_block_unsafe (block, symtab->objfile);
+  return SCM_BOOL_F;
+}
+
+/* Initialize the Scheme block support.  */
+
+static const scheme_function block_functions[] =
+{
+  { "block?", 1, 0, 0, gdbscm_block_p,
+    "\
+Return #t if the object is a <gdb:block> object." },
+
+  { "block-valid?", 1, 0, 0, gdbscm_block_valid_p,
+    "\
+Return #t if the block is valid.\n\
+A block becomes invalid when its objfile is freed." },
+
+  { "block-start", 1, 0, 0, gdbscm_block_start,
+    "\
+Return the start address of the block." },
+
+  { "block-end", 1, 0, 0, gdbscm_block_end,
+    "\
+Return the end address of the block." },
+
+  { "block-function", 1, 0, 0, gdbscm_block_function,
+    "\
+Return the gdb:symbol object of the function containing the block\n\
+or #f if the block does not live in any function." },
+
+  { "block-superblock", 1, 0, 0, gdbscm_block_superblock,
+    "\
+Return the superblock (parent block) of the block." },
+
+  { "block-global-block", 1, 0, 0, gdbscm_block_global_block,
+    "\
+Return the global block of the block." },
+
+  { "block-static-block", 1, 0, 0, gdbscm_block_static_block,
+    "\
+Return the static block of the block." },
+
+  { "block-global?", 1, 0, 0, gdbscm_block_global_p,
+    "\
+Return #t if block is a global block." },
+
+  { "block-static?", 1, 0, 0, gdbscm_block_static_p,
+    "\
+Return #t if block is a static block." },
+
+  { "block-symbols", 1, 0, 0, gdbscm_block_symbols,
+    "\
+Return a list of all symbols (as <gdb:symbol> objects) in the block." },
+
+  { "make-block-symbols-iterator", 1, 0, 0, gdbscm_make_block_syms_iter,
+    "\
+Return a <gdb:iterator> object for iterating over all symbols in the block." },
+
+  { "block-symbols-progress?", 1, 0, 0, bkscm_block_syms_progress_p,
+    "\
+Return #t if the object is a <gdb:block-symbols-progress> object." },
+
+  { "lookup-block", 1, 0, 0, gdbscm_lookup_block,
+    "\
+Return the innermost GDB block containing the address or #f if none found.\n\
+\n\
+  Arguments:\n\
+    address: the address to lookup" },
+
+  END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_blocks (void)
+{
+  block_smob_tag
+    = gdbscm_make_smob_type (block_smob_name, sizeof (block_smob));
+  scm_set_smob_mark (block_smob_tag, bkscm_mark_block_smob);
+  scm_set_smob_free (block_smob_tag, bkscm_free_block_smob);
+  scm_set_smob_print (block_smob_tag, bkscm_print_block_smob);
+
+  block_syms_progress_smob_tag
+    = gdbscm_make_smob_type (block_syms_progress_smob_name,
+			     sizeof (block_syms_progress_smob));
+  scm_set_smob_mark (block_syms_progress_smob_tag,
+		     bkscm_mark_block_syms_progress_smob);
+  scm_set_smob_print (block_syms_progress_smob_tag,
+		      bkscm_print_block_syms_progress_smob);
+
+  gdbscm_define_functions (block_functions, 1);
+
+  /* This function is "private".  */
+  bkscm_next_symbol_x_proc
+    = scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0,
+			  gdbscm_block_next_symbol_x);
+  scm_set_procedure_property_x (bkscm_next_symbol_x_proc,
+				gdbscm_documentation_symbol,
+				gdbscm_scm_from_c_string ("\
+Internal function to assist the block symbols iterator."));
+
+  /* Register an objfile "free" callback so we can properly
+     invalidate blocks when an object file is about to be deleted.  */
+  bkscm_objfile_data_key
+    = register_objfile_data_with_cleanup (NULL, bkscm_del_objfile_blocks);
+}
diff --git a/gdb/testsuite/gdb.guile/scm-block.c b/gdb/testsuite/gdb.guile/scm-block.c
new file mode 100644
index 0000000..d5ffa5b
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-block.c
@@ -0,0 +1,38 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+   Copyright 2010-2013 Free Software Foundation, Inc.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 3 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program.  If not, see  <http://www.gnu.org/licenses/>.  */
+
+int block_func (void)
+{
+  int i = 0;
+  {
+    double i = 1.0;
+    double f = 2.0;
+    {
+      const char *i = "stuff";
+      const char *f = "foo";
+      const char *b = "bar";
+      return 0; /* Block break here.  */
+    }
+  }
+}
+
+
+int main (int argc, char *argv[])
+{
+  block_func ();
+  return 0; /* Break at end. */
+}
diff --git a/gdb/testsuite/gdb.guile/scm-block.exp b/gdb/testsuite/gdb.guile/scm-block.exp
new file mode 100644
index 0000000..94f32ed
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-block.exp
@@ -0,0 +1,107 @@
+# Copyright (C) 2010-2013 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# This file is part of the GDB testsuite.
+# It tests the mechanism exposing blocks to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+    return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+    return
+}
+
+gdb_breakpoint [gdb_get_line_number "Block break here."]
+gdb_continue_to_breakpoint "Block break here."
+
+# Test initial innermost block.
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+    "Get frame inner"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+    "Get block inner"
+gdb_test "guile (print block)" "#<gdb:block $hex-$hex>" \
+    "Check block not #f"
+gdb_test "guile (print (block-function block))" \
+    "#f" "First anonymous block"
+gdb_test "guile (print (block-start block))" \
+    "${decimal}" "Check start not #f"
+gdb_test "guile (print (block-end block))" \
+    "${decimal}" "Check end not #f"
+
+# Test eq?.
+gdb_test "guile (print (eq? (frame-block frame) (frame-block frame)))" \
+     "= #t" "Check eq? on same block"
+gdb_test "guile (print (eq? block (block-global-block block)))" \
+     "= #f" "Check eq? on different blocks"
+
+# Test global/static blocks.
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+    "Get frame for global/static"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+    "Get block for global/static"
+gdb_test "guile (print (block-global? block))" \
+    "#f" "Not a global block"
+gdb_test "guile (print (block-static? block))" \
+    "#f" "Not a static block"
+gdb_scm_test_silent_cmd "guile (define gblock (block-global-block block))" \
+    "Get global block"
+gdb_scm_test_silent_cmd "guile (define sblock (block-static-block block))" \
+    "Get static block"
+gdb_test "guile (print (block-global? gblock))" \
+    "#t" "Is the global block"
+gdb_test "guile (print (block-static? sblock))" \
+    "#t" "Is the static block"
+
+# Move up superblock(s) until we reach function block_func.
+gdb_test_no_output "guile (set! block (block-superblock block))" \
+    "Get superblock"
+gdb_test "guile (print (block-function block))" \
+    "#f" "Second anonymous block"
+gdb_test_no_output "guile (set! block (block-superblock block))" \
+    "Get superblock 2"
+gdb_test "guile (print (block-function block))" \
+    "block_func" "Print superblock 2 function"
+
+# Switch frames, then test for main block.
+gdb_test "up" ".*"
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+    "Get frame 2"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+    "Get frame 2's block"
+gdb_test "guile (print block)" "#<gdb:block main $hex-$hex>" \
+    "Check Frame 2's block not #f"
+gdb_test "guile (print (block-function block))" \
+    "main" "main block"
+
+# Test block-valid?.  This must always be the last test in this
+# testcase as it unloads the object file.
+delete_breakpoints
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+    "Get frame for valid?"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+    "Get frame block for valid?"
+gdb_test "guile (print (block-valid? block))" \
+    "#t" "Check block validity"
+gdb_unload
+gdb_test "guile (print (block-valid? block))" \
+    "#f" "Check block validity after unload"