[PATCH v1 27/36] Guile extension language: scm-symbol.c

[Doug Evans <xdje42 at gmail dot com>]

This patch adds the interface to symbols.

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

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

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

diff --git a/gdb/guile/scm-symbol.c b/gdb/guile/scm-symbol.c
new file mode 100644
index 0000000..3cc51a7
--- /dev/null
+++ b/gdb/guile/scm-symbol.c
@@ -0,0 +1,798 @@
+/* Scheme interface to symbols.
+
+   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 "exceptions.h"
+#include "frame.h"
+#include "symtab.h"
+#include "objfiles.h"
+#include "value.h"
+#include "guile-internal.h"
+
+/* The <gdb:symbol> smob.  */
+
+typedef struct
+{
+  /* This always appears first.  */
+  eqable_gdb_smob base;
+
+  /* The GDB symbol structure this smob is wrapping.  */
+  struct symbol *symbol;
+} symbol_smob;
+
+static const char symbol_smob_name[] = "gdb:symbol";
+
+/* The tag Guile knows the symbol smob by.  */
+static scm_t_bits symbol_smob_tag;
+
+/* Keywords used in argument passing.  */
+static SCM syscm_block_keyword;
+static SCM syscm_domain_keyword;
+static SCM syscm_frame_keyword;
+
+static const struct objfile_data *syscm_objfile_data_key;
+
+/* Administrivia for symbol smobs.  */
+
+/* Helper function to hash a symbol_smob.  */
+
+static hashval_t
+syscm_hash_symbol_smob (const void *p)
+{
+  const symbol_smob *s_smob = p;
+
+  return htab_hash_pointer (s_smob->symbol);
+}
+
+/* Helper function to compute equality of symbol_smobs.  */
+
+static int
+syscm_eq_symbol_smob (const void *ap, const void *bp)
+{
+  const symbol_smob *a = ap;
+  const symbol_smob *b = bp;
+
+  return (a->symbol == b->symbol
+	  && a->symbol != NULL);
+}
+
+/* Return the struct symbol pointer -> SCM mapping table.
+   It is created if necessary.  */
+
+static htab_t
+syscm_objfile_symbol_map (struct symbol *symbol)
+{
+  struct objfile *objfile = SYMBOL_SYMTAB (symbol)->objfile;
+  htab_t htab = objfile_data (objfile, syscm_objfile_data_key);
+
+  if (htab == NULL)
+    {
+      htab = gdbscm_create_eqable_gsmob_ptr_map (syscm_hash_symbol_smob,
+						 syscm_eq_symbol_smob);
+      set_objfile_data (objfile, syscm_objfile_data_key, htab);
+    }
+
+  return htab;
+}
+
+/* The smob "mark" function for <gdb:symbol>.  */
+
+static SCM
+syscm_mark_symbol_smob (SCM self)
+{
+  symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
+
+  /* Do this last.  */
+  return gdbscm_mark_eqable_gsmob (&s_smob->base);
+}
+
+/* The smob "free" function for <gdb:symbol>.  */
+
+static size_t
+syscm_free_symbol_smob (SCM self)
+{
+  symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
+
+  if (s_smob->symbol != NULL)
+    {
+      htab_t htab = syscm_objfile_symbol_map (s_smob->symbol);
+
+      gdbscm_clear_eqable_gsmob_ptr_slot (htab, &s_smob->base);
+    }
+
+  /* Not necessary, done to catch bugs.  */
+  s_smob->symbol = NULL;
+
+  return 0;
+}
+
+/* The smob "print" function for <gdb:symbol>.  */
+
+static int
+syscm_print_symbol_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+  symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
+
+  if (pstate->writingp)
+    gdbscm_printf (port, "#<%s ", symbol_smob_name);
+  gdbscm_printf (port, "%s",
+		 s_smob->symbol != NULL
+		 ? SYMBOL_PRINT_NAME (s_smob->symbol)
+		 : "<invalid>");
+  if (pstate->writingp)
+    scm_puts (">", port);
+
+  scm_remember_upto_here_1 (self);
+
+  /* Non-zero means success.  */
+  return 1;
+}
+
+/* Low level routine to create a <gdb:symbol> object.  */
+
+static SCM
+syscm_make_symbol_smob (void)
+{
+  symbol_smob *s_smob = (symbol_smob *)
+    scm_gc_malloc (sizeof (symbol_smob), symbol_smob_name);
+  SCM s_scm;
+
+  s_smob->symbol = NULL;
+  s_scm = scm_new_smob (symbol_smob_tag, (scm_t_bits) s_smob);
+  gdbscm_init_eqable_gsmob (&s_smob->base);
+
+  return s_scm;
+}
+
+/* Return non-zero if SCM is a symbol smob.  */
+
+int
+syscm_is_symbol (SCM scm)
+{
+  return SCM_SMOB_PREDICATE (symbol_smob_tag, scm);
+}
+
+/* (symbol? object) -> boolean */
+
+static SCM
+gdbscm_symbol_p (SCM scm)
+{
+  return scm_from_bool (syscm_is_symbol (scm));
+}
+
+/* Return the existing object that encapsulates SYMBOL, or create a new
+   <gdb:symbol> object.
+   If the object is created it is passed through *smob->scm*.
+   A Scheme exception is thrown if there is an error.  */
+
+SCM
+syscm_scm_from_symbol_unsafe (struct symbol *symbol)
+{
+  htab_t htab;
+  eqable_gdb_smob **slot;
+  symbol_smob *s_smob, s_smob_for_lookup;
+  SCM s_scm, result;
+
+  /* If we've already created a gsmob for this symbol, return it.
+     This makes symbols eq?-able.  */
+  htab = syscm_objfile_symbol_map (symbol);
+  s_smob_for_lookup.symbol = symbol;
+  slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &s_smob_for_lookup.base);
+  if (*slot != NULL)
+    return (*slot)->containing_scm;
+
+  s_scm = syscm_make_symbol_smob ();
+  s_smob = (symbol_smob *) SCM_SMOB_DATA (s_scm);
+  s_smob->symbol = symbol;
+  result = gdbscm_scm_from_gsmob_unsafe (s_scm);
+  gdbscm_fill_eqable_gsmob_ptr_slot (slot, &s_smob->base, result);
+
+  return result;
+}
+
+/* Returns the <gdb:symbol> object contained in SCM or #f if SCM is not a
+   <gdb:symbol> object.
+   Returns a <gdb:exception> object if there was a problem during the
+   conversion.  */
+
+SCM
+syscm_scm_to_symbol_gsmob (SCM scm)
+{
+  return gdbscm_scm_to_gsmob_safe (scm, symbol_smob_tag);
+}
+
+/* Returns the <gdb:symbol> object in SELF.
+   Throws an exception if SELF is not a <gdb:symbol> object
+   (after passing it through *scm->smob*).  */
+
+static SCM
+syscm_get_symbol_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+  SCM s_scm = syscm_scm_to_symbol_gsmob (self);
+
+  if (gdbscm_is_exception (s_scm))
+    gdbscm_throw (s_scm);
+
+  SCM_ASSERT_TYPE (syscm_is_symbol (s_scm), self, arg_pos, func_name,
+		   symbol_smob_name);
+
+  return s_scm;
+}
+
+/* Returns a pointer to the symbol smob of SELF.
+   Throws an exception if SELF is not a <gdb:symbol> object
+   (after passing it through *scm->smob*).  */
+
+static symbol_smob *
+syscm_get_symbol_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+  SCM s_scm = syscm_get_symbol_arg_unsafe (self, arg_pos, func_name);
+  symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (s_scm);
+
+  return s_smob;
+}
+
+/* Return non-zero if symbol S_SMOB is valid.  */
+
+static int
+syscm_is_valid (symbol_smob *s_smob)
+{
+  return s_smob->symbol != NULL;
+}
+
+/* Throw a Scheme error if SELF is not a valid symbol smob.
+   Otherwise return a pointer to the symbol smob.  */
+
+static symbol_smob *
+syscm_get_valid_symbol_smob_arg_unsafe (SCM self, int arg_pos,
+					const char *func_name)
+{
+  symbol_smob *s_smob
+    = syscm_get_symbol_smob_arg_unsafe (self, arg_pos, func_name);
+
+  if (!syscm_is_valid (s_smob))
+    {
+      gdbscm_invalid_object_error (func_name, arg_pos, self,
+				   _("<gdb:symbol>"));
+    }
+
+  return s_smob;
+}
+
+/* Throw a Scheme error if SELF is not a valid symbol smob.
+   Otherwise return a pointer to the symbol struct.  */
+
+struct symbol *
+syscm_get_valid_symbol_arg_unsafe (SCM self, int arg_pos,
+				   const char *func_name)
+{
+  symbol_smob *s_smob = syscm_get_valid_symbol_smob_arg_unsafe (self, arg_pos,
+								func_name);
+
+  return s_smob->symbol;
+}
+
+/* Helper function for syscm_del_objfile_symbols to mark the symbol
+   as invalid.  */
+
+static int
+syscm_mark_symbol_invalid (void **slot, void *info)
+{
+  symbol_smob *s_smob = (symbol_smob *) *slot;
+
+  s_smob->symbol = NULL;
+  return 1;
+}
+
+/* This function is called when an objfile is about to be freed.
+   Invalidate the symbol as further actions on the symbol would result
+   in bad data.  All access to s_smob->symbol should be gated by
+   syscm_get_valid_symbol_smob_arg_unsafe which will raise an exception on
+   invalid symbols.  */
+
+static void
+syscm_del_objfile_symbols (struct objfile *objfile, void *datum)
+{
+  htab_t htab = datum;
+
+  if (htab != NULL)
+    {
+      htab_traverse_noresize (htab, syscm_mark_symbol_invalid, NULL);
+      htab_delete (htab);
+    }
+}
+
+/* Symbol methods.  */
+
+/* (symbol-valid? <gdb:symbol>) -> boolean
+   Returns #t if SELF still exists in GDB.  */
+
+static SCM
+gdbscm_symbol_valid_p (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+  return scm_from_bool (syscm_is_valid (s_smob));
+}
+
+/* (symbol-type <gdb:symbol>) -> <gdb:type>
+   Return the type of SELF, or #f if SELF has no type.  */
+
+static SCM
+gdbscm_symbol_type (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+
+  if (SYMBOL_TYPE (symbol) == NULL)
+    return SCM_BOOL_F;
+
+  return tyscm_scm_from_type_unsafe (SYMBOL_TYPE (symbol));
+}
+
+/* (symbol-symtab <gdb:symbol>) -> <gdb:symtab>
+   Return the symbol table of SELF.  */
+
+static SCM
+gdbscm_symbol_symtab (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+
+  return stscm_scm_from_symtab_unsafe (SYMBOL_SYMTAB (symbol));
+}
+
+/* (symbol-name <gdb:symbol>) -> string */
+
+static SCM
+gdbscm_symbol_name (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+
+  return gdbscm_scm_from_c_string (SYMBOL_NATURAL_NAME (symbol));
+}
+
+/* (symbol-linkage-name <gdb:symbol>) -> string */
+
+static SCM
+gdbscm_symbol_linkage_name (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+
+  return gdbscm_scm_from_c_string (SYMBOL_LINKAGE_NAME (symbol));
+}
+
+/* (symbol-print-name <gdb:symbol>) -> string */
+
+static SCM
+gdbscm_symbol_print_name (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+
+  return gdbscm_scm_from_c_string (SYMBOL_PRINT_NAME (symbol));
+}
+
+/* (symbol-addr-class <gdb:symbol>) -> integer */
+
+static SCM
+gdbscm_symbol_addr_class (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+
+  return scm_from_int (SYMBOL_CLASS (symbol));
+}
+
+/* (symbol-argument? <gdb:symbol>) -> boolean */
+
+static SCM
+gdbscm_symbol_argument_p (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+
+  return scm_from_bool (SYMBOL_IS_ARGUMENT (symbol));
+}
+
+/* (symbol-constant? <gdb:symbol>) -> boolean */
+
+static SCM
+gdbscm_symbol_constant_p (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+  enum address_class class;
+
+  class = SYMBOL_CLASS (symbol);
+
+  return scm_from_bool (class == LOC_CONST || class == LOC_CONST_BYTES);
+}
+
+/* (symbol-function? <gdb:symbol>) -> boolean */
+
+static SCM
+gdbscm_symbol_function_p (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+  enum address_class class;
+
+  class = SYMBOL_CLASS (symbol);
+
+  return scm_from_bool (class == LOC_BLOCK);
+}
+
+/* (symbol-variable? <gdb:symbol>) -> boolean */
+
+static SCM
+gdbscm_symbol_variable_p (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+  enum address_class class;
+
+  class = SYMBOL_CLASS (symbol);
+
+  return scm_from_bool (!SYMBOL_IS_ARGUMENT (symbol)
+			&& (class == LOC_LOCAL || class == LOC_REGISTER
+			    || class == LOC_STATIC || class == LOC_COMPUTED
+			    || class == LOC_OPTIMIZED_OUT));
+}
+
+/* (symbol-needs-frame? <gdb:symbol>) -> boolean
+   Return #t if the symbol needs a frame for evaluation.  */
+
+static SCM
+gdbscm_symbol_needs_frame_p (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  struct symbol *symbol = s_smob->symbol;
+  volatile struct gdb_exception except;
+  int result = 0;
+
+  TRY_CATCH (except, RETURN_MASK_ALL)
+    {
+      result = symbol_read_needs_frame (symbol);
+    }
+  GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+  return scm_from_bool (result);
+}
+
+/* (symbol-line <gdb:symbol>) -> integer
+   Return the line number at which the symbol was defined.  */
+
+static SCM
+gdbscm_symbol_line (SCM self)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  const struct symbol *symbol = s_smob->symbol;
+
+  return scm_from_int (SYMBOL_LINE (symbol));
+}
+
+/* (symbol-value <gdb:symbol> [#:frame <gdb:frame>]) -> <gdb:value>
+   Return the value of the symbol, or an error in various circumstances.  */
+
+static SCM
+gdbscm_symbol_value (SCM self, SCM rest)
+{
+  symbol_smob *s_smob
+    = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+  struct symbol *symbol = s_smob->symbol;
+  SCM keywords[] = { syscm_frame_keyword, SCM_BOOL_F };
+  int frame_pos = -1;
+  SCM frame_scm = SCM_BOOL_F;
+  frame_smob *f_smob = NULL;
+  struct frame_info *frame_info = NULL;
+  struct value *value = NULL;
+  volatile struct gdb_exception except;
+
+  gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O",
+			      rest, &frame_pos, &frame_scm);
+  if (!gdbscm_is_false (frame_scm))
+    f_smob = frscm_get_frame_smob_arg_unsafe (frame_scm, frame_pos, FUNC_NAME);
+
+  if (SYMBOL_CLASS (symbol) == LOC_TYPEDEF)
+    {
+      gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+				 _("cannot get the value of a typedef"));
+    }
+
+  TRY_CATCH (except, RETURN_MASK_ALL)
+    {
+      if (f_smob != NULL)
+	{
+	  frame_info = frscm_frame_smob_to_frame (f_smob);
+	  if (frame_info == NULL)
+	    error (_("Invalid frame"));
+	}
+      
+      if (symbol_read_needs_frame (symbol) && frame_info == NULL)
+	error (_("Symbol requires a frame to compute its value"));
+
+      value = read_var_value (symbol, frame_info);
+    }
+  GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+  return vlscm_scm_from_value_unsafe (value);
+}
+
+/* (lookup-symbol name [#:block <gdb:block>] [#:domain domain])
+     -> (<gdb:symbol> field-of-this?)
+   The result is #f if the symbol is not found.
+   See comment in lookup_symbol_in_language for field-of-this?.  */
+
+static SCM
+gdbscm_lookup_symbol (SCM name_scm, SCM rest)
+{
+  char *name;
+  SCM keywords[] = { syscm_block_keyword, syscm_domain_keyword, SCM_BOOL_F };
+  const struct block *block = NULL;
+  SCM block_scm = SCM_BOOL_F;
+  int domain = VAR_DOMAIN;
+  int block_arg_pos = -1, domain_arg_pos = -1;
+  struct field_of_this_result is_a_field_of_this;
+  struct symbol *symbol = NULL;
+  volatile struct gdb_exception except;
+  struct cleanup *cleanups;
+
+  gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#Oi",
+			      name_scm, &name, rest,
+			      &block_arg_pos, &block_scm,
+			      &domain_arg_pos, &domain);
+
+  cleanups = make_cleanup (xfree, name);
+
+  if (block_arg_pos >= 0)
+    {
+      SCM except_scm;
+
+      block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
+				  &except_scm);
+      if (block == NULL)
+	{
+	  do_cleanups (cleanups);
+	  gdbscm_throw (except_scm);
+	}
+    }
+  else
+    {
+      struct frame_info *selected_frame;
+
+      TRY_CATCH (except, RETURN_MASK_ALL)
+	{
+	  selected_frame = get_selected_frame (_("no frame selected"));
+	  block = get_frame_block (selected_frame, NULL);
+	}
+      GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+    }
+
+  TRY_CATCH (except, RETURN_MASK_ALL)
+    {
+      symbol = lookup_symbol (name, block, domain, &is_a_field_of_this);
+    }
+  do_cleanups (cleanups);
+  GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+  if (symbol == NULL)
+    return SCM_BOOL_F;
+
+  return scm_list_2 (syscm_scm_from_symbol_unsafe (symbol),
+		     scm_from_bool (is_a_field_of_this.type != NULL));
+}
+
+/* (lookup-global-symbol name [#:domain domain]) -> <gdb:symbol>
+   The result is #f if the symbol is not found.  */
+
+static SCM
+gdbscm_lookup_global_symbol (SCM name_scm, SCM rest)
+{
+  char *name;
+  SCM keywords[] = { syscm_domain_keyword, SCM_BOOL_F };
+  int domain_arg_pos = -1;
+  int domain = VAR_DOMAIN;
+  struct symbol *symbol = NULL;
+  volatile struct gdb_exception except;
+  struct cleanup *cleanups;
+
+  gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#i",
+			      name_scm, &name, rest,
+			      &domain_arg_pos, &domain);
+
+  cleanups = make_cleanup (xfree, name);
+
+  TRY_CATCH (except, RETURN_MASK_ALL)
+    {
+      symbol = lookup_symbol_global (name, NULL, domain);
+    }
+  do_cleanups (cleanups);
+  GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+  if (symbol == NULL)
+    return SCM_BOOL_F;
+
+  return syscm_scm_from_symbol_unsafe (symbol);
+}
+
+/* Initialize the Scheme symbol support.  */
+
+/* Note: The SYMBOL_ prefix on the integer constants here is present for
+   compatibility with the Python support.  */
+
+static const scheme_integer_constant symbol_integer_constants[] =
+{
+#define X(SYM) { "SYMBOL_" #SYM, SYM }
+  X (LOC_UNDEF),
+  X (LOC_CONST),
+  X (LOC_STATIC),
+  X (LOC_REGISTER),
+  X (LOC_ARG),
+  X (LOC_REF_ARG),
+  X (LOC_LOCAL),
+  X (LOC_TYPEDEF),
+  X (LOC_LABEL),
+  X (LOC_BLOCK),
+  X (LOC_CONST_BYTES),
+  X (LOC_UNRESOLVED),
+  X (LOC_OPTIMIZED_OUT),
+  X (LOC_COMPUTED),
+  X (LOC_REGPARM_ADDR),
+
+  X (UNDEF_DOMAIN),
+  X (VAR_DOMAIN),
+  X (STRUCT_DOMAIN),
+  X (LABEL_DOMAIN),
+  X (VARIABLES_DOMAIN),
+  X (FUNCTIONS_DOMAIN),
+  X (TYPES_DOMAIN),
+#undef X
+
+  END_INTEGER_CONSTANTS
+};
+
+static const scheme_function symbol_functions[] =
+{
+  { "symbol?", 1, 0, 0, gdbscm_symbol_p,
+    "\
+Return #t if the object is a <gdb:symbol> object." },
+
+  { "symbol-valid?", 1, 0, 0, gdbscm_symbol_valid_p,
+    "\
+Return #t if object is a valid <gdb:symbol> object.\n\
+A valid symbol is a symbol that has not been freed.\n\
+Symbols are freed when the objfile they come from is freed." },
+
+  { "symbol-type", 1, 0, 0, gdbscm_symbol_type,
+    "\
+Return the type of symbol." },
+
+  { "symbol-symtab", 1, 0, 0, gdbscm_symbol_symtab,
+    "\
+Return the symbol table (<gdb:symtab>) containing symbol." },
+
+  { "symbol-line", 1, 0, 0, gdbscm_symbol_line,
+    "\
+Return the line number at which the symbol was defined." },
+
+  { "symbol-name", 1, 0, 0, gdbscm_symbol_name,
+    "\
+Return the name of the symbol as a string." },
+
+  { "symbol-linkage-name", 1, 0, 0, gdbscm_symbol_linkage_name,
+    "\
+Return the linkage name of the symbol as a string." },
+
+  { "symbol-print-name", 1, 0, 0, gdbscm_symbol_print_name,
+    "\
+Return the print name of the symbol as a string.\n\
+This is either name or linkage-name, depending on whether the user\n\
+asked GDB to display demangled or mangled names." },
+
+  { "symbol-addr-class", 1, 0, 0, gdbscm_symbol_addr_class,
+    "\
+Return the address class of the symbol." },
+
+  { "symbol-needs-frame?", 1, 0, 0, gdbscm_symbol_needs_frame_p,
+    "\
+Return #t if the symbol needs a frame to compute its value." },
+
+  { "symbol-argument?", 1, 0, 0, gdbscm_symbol_argument_p,
+    "\
+Return #t if the symbol is a function argument." },
+
+  { "symbol-constant?", 1, 0, 0, gdbscm_symbol_constant_p,
+    "\
+Return #t if the symbol is a constant." },
+
+  { "symbol-function?", 1, 0, 0, gdbscm_symbol_function_p,
+    "\
+Return #t if the symbol is a function." },
+
+  { "symbol-variable?", 1, 0, 0, gdbscm_symbol_variable_p,
+    "\
+Return #t if the symbol is a variable." },
+
+  { "symbol-value", 1, 0, 1, gdbscm_symbol_value,
+    "\
+Return the value of the symbol.\n\
+\n\
+  Arguments: <gdb:symbol> [#:frame frame]" },
+
+  { "lookup-symbol", 1, 0, 1, gdbscm_lookup_symbol,
+    "\
+Return (<gdb:symbol> field-of-this?) if found, otherwise #f.\n\
+\n\
+  Arguments: name [#:block block] [#:domain domain]\n\
+    name:   a string containing the name of the symbol to lookup\n\
+    block:  a <gdb:block> object\n\
+    domain: a SYMBOL_*_DOMAIN value" },
+
+  { "lookup-global-symbol", 1, 0, 1, gdbscm_lookup_global_symbol,
+    "\
+Return <gdb:symbol> if found, otherwise #f.\n\
+\n\
+  Arguments: name [#:domain domain]\n\
+    name:   a string containing the name of the symbol to lookup\n\
+    domain: a SYMBOL_*_DOMAIN value" },
+
+  END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_symbols (void)
+{
+  symbol_smob_tag
+    = gdbscm_make_smob_type (symbol_smob_name, sizeof (symbol_smob));
+  scm_set_smob_mark (symbol_smob_tag, syscm_mark_symbol_smob);
+  scm_set_smob_free (symbol_smob_tag, syscm_free_symbol_smob);
+  scm_set_smob_print (symbol_smob_tag, syscm_print_symbol_smob);
+
+  gdbscm_define_integer_constants (symbol_integer_constants, 1);
+  gdbscm_define_functions (symbol_functions, 1);
+
+  syscm_block_keyword = scm_from_latin1_keyword ("block");
+  syscm_domain_keyword = scm_from_latin1_keyword ("domain");
+  syscm_frame_keyword = scm_from_latin1_keyword ("frame");
+
+  /* Register an objfile "free" callback so we can properly
+     invalidate symbols when an object file is about to be deleted.  */
+  syscm_objfile_data_key
+    = register_objfile_data_with_cleanup (NULL, syscm_del_objfile_symbols);
+}
diff --git a/gdb/testsuite/gdb.guile/scm-symbol.c b/gdb/testsuite/gdb.guile/scm-symbol.c
new file mode 100644
index 0000000..53b1900
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-symbol.c
@@ -0,0 +1,69 @@
+/* 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/>.  */
+
+#ifdef __cplusplus
+class SimpleClass
+{
+ private:
+  int i;
+
+ public:
+  void seti (int arg)
+  {
+    i = arg;
+  }
+
+  int valueofi (void)
+  {
+    return i; /* Break in class. */
+  }
+};
+#endif
+
+int qq = 72;			/* line of qq */
+
+int func (int arg)
+{
+  int i = 2;
+  i = i * arg; /* Block break here.  */
+  return arg;
+}
+
+struct simple_struct
+{
+  int a;
+};
+
+int main (int argc, char *argv[])
+{
+#ifdef __cplusplus
+  SimpleClass sclass;
+#endif
+  int a = 0;
+  int result;
+  struct simple_struct ss = { 10 };
+  enum tag {one, two, three};
+  enum tag t = one;
+
+  result = func (42);
+
+#ifdef __cplusplus
+  sclass.seti (42);
+  sclass.valueofi ();
+#endif
+  return 0; /* Break at end.  */
+}
diff --git a/gdb/testsuite/gdb.guile/scm-symbol.exp b/gdb/testsuite/gdb.guile/scm-symbol.exp
new file mode 100644
index 0000000..50f0181
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-symbol.exp
@@ -0,0 +1,196 @@
+# 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 symbols to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if {[prepare_for_testing $testfile.exp $testfile $srcfile debug]} {
+    return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+# These tests are done before we call gdb_guile_runto_main so we have to
+# import the gdb module ourselves.
+gdb_install_guile_utils
+gdb_install_guile_module
+
+# Test looking up a global symbol before we runto_main as this is the
+# point where we don't have a current frame, and we don't want to
+# require one.
+gdb_scm_test_silent_cmd "guile (define main-func (lookup-global-symbol \"main\"))" \
+    "lookup main"
+gdb_test "guile (print (symbol-function? main-func))" \
+    "= #t" "test (symbol-function? main)"
+gdb_test "guile (print (lookup-global-symbol \"junk\"))" \
+    "= #f" "test (lookup-global-symbol junk)"
+
+gdb_test "guile (print (symbol-value main-func))" \
+    "= {int \\(int, char \[*\]\[*\]\\)} $hex \\<main\\>" "print value of main"
+
+set qq_line [gdb_get_line_number "line of qq"]
+gdb_scm_test_silent_cmd "guile (define qq-var (lookup-global-symbol \"qq\"))" \
+    "lookup qq"
+gdb_test "guile (print (symbol-line qq-var))" \
+    "= $qq_line" "print line number of qq"
+gdb_test "guile (print (symbol-value qq-var))" \
+    "= 72" "print value of qq"
+gdb_test "guile (print (symbol-needs-frame? qq-var))" \
+    "= #f" "print whether qq needs a frame"
+
+if ![gdb_guile_runto_main] {
+    return
+}
+
+# Test symbol eq? and equal?.
+gdb_test "guile (print (eq? (lookup-global-symbol \"main\") (lookup-global-symbol \"main\")))" \
+    "= #t"
+gdb_test "guile (print (equal? (lookup-global-symbol \"main\") (lookup-global-symbol \"main\")))" \
+    "= #t"
+
+gdb_breakpoint [gdb_get_line_number "Block break here."]
+gdb_continue_to_breakpoint "Block break here."
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+    "get frame at block break"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+    "get block at block break"
+
+# Test symbol-argument?.
+gdb_scm_test_silent_cmd "guile (define arg (car (lookup-symbol \"arg\")))" \
+    "get variable arg"
+gdb_test "guile (print (symbol-variable? arg))" "= #f"
+gdb_test "guile (print (symbol-constant? arg))" "= #f"
+gdb_test "guile (print (symbol-argument? arg))" "= #t"
+gdb_test "guile (print (symbol-function? arg))" "= #f"
+
+# Test symbol-function?.
+gdb_scm_test_silent_cmd "guile (define func (block-function block))" \
+    "get block function"
+gdb_test "guile (print (symbol-variable? func))" "= #f"
+gdb_test "guile (print (symbol-constant? func))" "= #f"
+gdb_test "guile (print (symbol-argument? func))" "= #f"
+gdb_test "guile (print (symbol-function? func))" "= #t"
+
+# Test attributes of func.
+gdb_test "guile (print (symbol-name func))" "func"
+gdb_test "guile (print (symbol-print-name func))" "func"
+gdb_test "guile (print (symbol-linkage-name func))" "func"
+gdb_test "guile (print (= (symbol-addr-class func) SYMBOL_LOC_BLOCK))" "= #t"
+
+gdb_breakpoint [gdb_get_line_number "Break at end."]
+gdb_continue_to_breakpoint "Break at end."
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+    "get frame at end"
+
+# Test symbol-variable?.
+gdb_scm_test_silent_cmd "guile (define a (car (lookup-symbol \"a\")))" \
+    "get variable a"
+gdb_test "guile (print (symbol-variable? a))" "= #t"
+gdb_test "guile (print (symbol-constant? a))" "= #f"
+gdb_test "guile (print (symbol-argument? a))" "= #f"
+gdb_test "guile (print (symbol-function? a))" "= #f"
+
+# Test attributes of a.
+gdb_test "guile (print (= (symbol-addr-class a) SYMBOL_LOC_COMPUTED))" "= #t"
+
+gdb_test "guile (print (symbol-value a))" \
+    "ERROR: Symbol requires a frame to compute its value.*"\
+    "try to print value of a without a frame"
+gdb_test "guile (print (symbol-value a #:frame frame))" \
+    "= 0" "print value of a"
+gdb_test "guile (print (symbol-needs-frame? a))" \
+    "= #t" "print whether a needs a frame"
+
+# Test symbol-constant?.
+gdb_scm_test_silent_cmd "guile (define t (car (lookup-symbol \"one\")))" \
+    "get constant t"
+gdb_test "guile (print (symbol-variable? t))" "= #f"
+gdb_test "guile (print (symbol-constant? t))" "= #t"
+gdb_test "guile (print (symbol-argument? t))" "= #f"
+gdb_test "guile (print (symbol-function? t))" "= #f"
+
+# Test attributes of t.
+gdb_test "guile (print (= (symbol-addr-class t) SYMBOL_LOC_CONST))" "= #t"
+
+# Test type attribute.
+gdb_test "guile (print (symbol-type t))" "= enum tag"
+
+# Test symtab attribute.
+gdb_test "guile (print (symbol-symtab t))" "= #<gdb:symtab .*gdb.guile/scm-symbol.c>"
+
+# C++ tests
+# Recompile binary.
+if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}-cxx" executable "debug c++"] != "" } {
+    untested "Couldn't compile ${srcfile} in c++ mode"
+    return -1
+}
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}-cxx
+
+if ![gdb_guile_runto_main] {
+    return
+}
+
+gdb_breakpoint [gdb_get_line_number "Break in class."]
+gdb_continue_to_breakpoint "Break in class."
+
+gdb_scm_test_silent_cmd "guile (define cplusframe (selected-frame))" \
+    "get frame at class"
+gdb_scm_test_silent_cmd "guile (define cplusfunc (block-function (frame-block cplusframe)))" \
+    "get function at class"
+
+gdb_test "guile (print (symbol-variable? cplusfunc))" "= #f"
+gdb_test "guile (print (symbol-constant? cplusfunc))" "= #f"
+gdb_test "guile (print (symbol-argument? cplusfunc))" "= #f"
+gdb_test "guile (print (symbol-function? cplusfunc))" "= #t"
+
+gdb_test "guile (print (symbol-name cplusfunc))" \
+    "= SimpleClass::valueofi().*" "test method.name"
+gdb_test "guile (print (symbol-print-name cplusfunc))" \
+    "= SimpleClass::valueofi().*" "test method.print_name"
+# FIXME: GDB is broken here and we're verifying broken behaviour.
+# (linkage-name should be the mangled name)
+gdb_test "guile (print (symbol-linkage-name cplusfunc))" \
+    "SimpleClass::valueofi().*" "test method.linkage_name"
+gdb_test "guile (print (= (symbol-addr-class cplusfunc) SYMBOL_LOC_BLOCK))" "= #t"
+
+# Test is_valid when the objfile is unloaded.  This must be the last
+# test as it unloads the object file in GDB.
+# Start with a fresh gdb.
+clean_restart ${testfile}
+if ![gdb_guile_runto_main] {
+    return
+}
+
+gdb_breakpoint [gdb_get_line_number "Break at end."]
+gdb_continue_to_breakpoint "Break at end."
+gdb_scm_test_silent_cmd "guile (define a (car (lookup-symbol \"a\")))" \
+    "get variable a for unload"
+gdb_test "guile (print (symbol-valid? a))" \
+    "= #t" "test symbol validity pre-unload"
+delete_breakpoints
+gdb_unload
+gdb_test "guile (print (symbol-valid? a))" \
+    "= #f" "test symbol validity post-unload"
+gdb_test_no_output "guile (set! a #f) (gc)" "test symbol destructor"