aboutsummaryrefslogtreecommitdiff
path: root/gdb/guile/scm-symbol.c
diff options
context:
space:
mode:
authorDoug Evans <xdje42@gmail.com>2014-02-09 19:40:01 -0800
committerDoug Evans <xdje42@gmail.com>2014-02-09 19:40:01 -0800
commited3ef33944c39d9a3cea72b9a7cef3c20f0e3461 (patch)
tree4e67d95b8ea65bb36a9cade5e37df2ad6289052e /gdb/guile/scm-symbol.c
parent7026a7c16ee82d39e84823f8cc3097a9a940ddb2 (diff)
downloadgdb-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.zip
gdb-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.tar.gz
gdb-ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461.tar.bz2
Add Guile as an extension language.
* NEWS: Mention Guile scripting. * Makefile.in (SUBDIR_GUILE_OBS): New variable. (SUBDIR_GUILE_SRCS, SUBDIR_GUILE_DEPS): New variables (SUBDIR_GUILE_LDFLAGS, SUBDIR_GUILE_CFLAGS): New variables. (INTERNAL_CPPFLAGS): Add GUILE_CPPFLAGS. (CLIBS): Add GUILE_LIBS. (install-guile): New rule. (guile.o): New rule. (scm-arch.o, scm-auto-load.o, scm-block.o): New rules. (scm-breakpoint.o, scm-disasm.o, scm-exception.o): New rules. (scm-frame.o, scm-iterator.o, scm-lazy-string.o): New rules. (scm-math.o, scm-objfile.o, scm-ports.o): New rules. (scm-pretty-print.o, scm-safe-call.o, scm-gsmob.o): New rules. (scm-string.o, scm-symbol.o, scm-symtab.o): New rules. (scm-type.o, scm-utils.o, scm-value.o): New rules. * configure.ac: New option --with-guile. * configure: Regenerate. * config.in: Regenerate. * auto-load.c: Remove #include "python/python.h". Add #include "gdb/section-scripts.h". (source_section_scripts): Handle Guile scripts. (_initialize_auto_load): Add name of Guile objfile script to scripts-directory help text. * breakpoint.c (condition_command): Tweak comment to include Scheme. * breakpoint.h (gdbscm_breakpoint_object): Add forward decl. (struct breakpoint): New member scm_bp_object. * defs.h (enum command_control_type): New value guile_control. * cli/cli-cmds.c: Remove #include "python/python.h". Add #include "extension.h". (show_user): Update comment. (_initialize_cli_cmds): Update help text for "show user". Update help text for max-user-call-depth. * cli/cli-script.c: Remove #include "python/python.h". Add #include "extension.h". (multi_line_command_p): Add guile_control. (print_command_lines): Handle guile_control. (execute_control_command, recurse_read_control_structure): Ditto. (process_next_line): Recognize "guile" commands. * disasm.c (gdb_disassemble_info): Make non-static. * disasm.h: #include "dis-asm.h". (struct gdbarch): Add forward decl. (gdb_disassemble_info): Declare. * extension.c: #include "guile/guile.h". (extension_languages): Add guile. (get_ext_lang_defn): Handle EXT_LANG_GDB. * extension.h (enum extension_language): New value EXT_LANG_GUILE. * gdbtypes.c (get_unsigned_type_max): New function. (get_signed_type_minmax): New function. * gdbtypes.h (get_unsigned_type_max): Declare. (get_signed_type_minmax): Declare. * guile/README: New file. * guile/guile-internal.h: New file. * guile/guile.c: New file. * guile/guile.h: New file. * guile/scm-arch.c: New file. * guile/scm-auto-load.c: New file. * guile/scm-block.c: New file. * guile/scm-breakpoint.c: New file. * guile/scm-disasm.c: New file. * guile/scm-exception.c: New file. * guile/scm-frame.c: New file. * guile/scm-gsmob.c: New file. * guile/scm-iterator.c: New file. * guile/scm-lazy-string.c: New file. * guile/scm-math.c: New file. * guile/scm-objfile.c: New file. * guile/scm-ports.c: New file. * guile/scm-pretty-print.c: New file. * guile/scm-safe-call.c: New file. * guile/scm-string.c: New file. * guile/scm-symbol.c: New file. * guile/scm-symtab.c: New file. * guile/scm-type.c: New file. * guile/scm-utils.c: New file. * guile/scm-value.c: New file. * guile/lib/gdb.scm: New file. * guile/lib/gdb/boot.scm: New file. * guile/lib/gdb/experimental.scm: New file. * guile/lib/gdb/init.scm: New file. * guile/lib/gdb/iterator.scm: New file. * guile/lib/gdb/printing.scm: New file. * guile/lib/gdb/types.scm: New file. * data-directory/Makefile.in (GUILE_SRCDIR): New variable. (VPATH): Add $(GUILE_SRCDIR). (GUILE_DIR): New variable. (GUILE_INSTALL_DIR, GUILE_FILES): New variables. (all): Add stamp-guile dependency. (stamp-guile): New rule. (clean-guile, install-guile, uninstall-guile): New rules. (install-only): Add install-guile dependency. (uninstall): Add uninstall-guile dependency. (clean): Add clean-guile dependency. doc/ * Makefile.in (GDB_DOC_FILES): Add guile.texi. * gdb.texinfo (Auto-loading): Add set/show auto-load guile-scripts. (Extending GDB): New menu entries Guile, Multiple Extension Languages. (Guile docs): Include guile.texi. (objfile-gdbdotext file): Add objfile-gdb.scm. (dotdebug_gdb_scripts section): Mention Guile scripts. (Multiple Extension Languages): New node. * guile.texi: New file. testsuite/ * configure.ac (AC_OUTPUT): Add gdb.guile. * configure: Regenerate. * lib/gdb-guile.exp: New file. * lib/gdb.exp (get_target_charset): New function. * gdb.base/help.exp: Update expected output from "apropos apropos". * gdb.guile/Makefile.in: New file. * gdb.guile/guile.exp: New file. * gdb.guile/scm-arch.c: New file. * gdb.guile/scm-arch.exp: New file. * gdb.guile/scm-block.c: New file. * gdb.guile/scm-block.exp: New file. * gdb.guile/scm-breakpoint.c: New file. * gdb.guile/scm-breakpoint.exp: New file. * gdb.guile/scm-disasm.c: New file. * gdb.guile/scm-disasm.exp: New file. * gdb.guile/scm-equal.c: New file. * gdb.guile/scm-equal.exp: New file. * gdb.guile/scm-error.exp: New file. * gdb.guile/scm-error.scm: New file. * gdb.guile/scm-frame-args.c: New file. * gdb.guile/scm-frame-args.exp: New file. * gdb.guile/scm-frame-args.scm: New file. * gdb.guile/scm-frame-inline.c: New file. * gdb.guile/scm-frame-inline.exp: New file. * gdb.guile/scm-frame.c: New file. * gdb.guile/scm-frame.exp: New file. * gdb.guile/scm-generics.exp: New file. * gdb.guile/scm-gsmob.exp: New file. * gdb.guile/scm-iterator.c: New file. * gdb.guile/scm-iterator.exp: New file. * gdb.guile/scm-math.c: New file. * gdb.guile/scm-math.exp: New file. * gdb.guile/scm-objfile-script-gdb.in: New file. * gdb.guile/scm-objfile-script.c: New file. * gdb.guile/scm-objfile-script.exp: New file. * gdb.guile/scm-objfile.c: New file. * gdb.guile/scm-objfile.exp: New file. * gdb.guile/scm-ports.exp: New file. * gdb.guile/scm-pretty-print.c: New file. * gdb.guile/scm-pretty-print.exp: New file. * gdb.guile/scm-pretty-print.scm: New file. * gdb.guile/scm-section-script.c: New file. * gdb.guile/scm-section-script.exp: New file. * gdb.guile/scm-section-script.scm: New file. * gdb.guile/scm-symbol.c: New file. * gdb.guile/scm-symbol.exp: New file. * gdb.guile/scm-symtab-2.c: New file. * gdb.guile/scm-symtab.c: New file. * gdb.guile/scm-symtab.exp: New file. * gdb.guile/scm-type.c: New file. * gdb.guile/scm-type.exp: New file. * gdb.guile/scm-value-cc.cc: New file. * gdb.guile/scm-value-cc.exp: New file. * gdb.guile/scm-value.c: New file. * gdb.guile/scm-value.exp: New file. * gdb.guile/source2.scm: New file. * gdb.guile/types-module.cc: New file. * gdb.guile/types-module.exp: New file.
Diffstat (limited to 'gdb/guile/scm-symbol.c')
-rw-r--r--gdb/guile/scm-symbol.c777
1 files changed, 777 insertions, 0 deletions
diff --git a/gdb/guile/scm-symbol.c b/gdb/guile/scm-symbol.c
new file mode 100644
index 0000000..53cc272
--- /dev/null
+++ b/gdb/guile/scm-symbol.c
@@ -0,0 +1,777 @@
+/* Scheme interface to symbols.
+
+ Copyright (C) 2008-2014 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 block_keyword;
+static SCM domain_keyword;
+static SCM 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. */
+
+SCM
+syscm_scm_from_symbol (struct symbol *symbol)
+{
+ htab_t htab;
+ eqable_gdb_smob **slot;
+ symbol_smob *s_smob, s_smob_for_lookup;
+ SCM s_scm;
+
+ /* 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;
+ gdbscm_fill_eqable_gsmob_ptr_slot (slot, &s_smob->base, s_scm);
+
+ return s_scm;
+}
+
+/* Returns the <gdb:symbol> object in SELF.
+ Throws an exception if SELF is not a <gdb:symbol> object. */
+
+static SCM
+syscm_get_symbol_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (syscm_is_symbol (self), self, arg_pos, func_name,
+ symbol_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the symbol smob of SELF.
+ Throws an exception if SELF is not a <gdb:symbol> object. */
+
+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 (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 (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[] = { 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 (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[] = { block_keyword, 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 (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[] = { 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 (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);
+
+ block_keyword = scm_from_latin1_keyword ("block");
+ domain_keyword = scm_from_latin1_keyword ("domain");
+ 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);
+}