From ed3ef33944c39d9a3cea72b9a7cef3c20f0e3461 Mon Sep 17 00:00:00 2001 From: Doug Evans Date: Sun, 9 Feb 2014 19:40:01 -0800 Subject: 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. --- gdb/guile/scm-block.c | 828 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 828 insertions(+) create mode 100644 gdb/guile/scm-block.c (limited to 'gdb/guile/scm-block.c') diff --git a/gdb/guile/scm-block.c b/gdb/guile/scm-block.c new file mode 100644 index 0000000..de41af2 --- /dev/null +++ b/gdb/guile/scm-block.c @@ -0,0 +1,828 @@ +/* Scheme interface to blocks. + + 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 . */ + +/* 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 . 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 . */ + +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 . */ + +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 . */ + +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 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 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)); +} + +/* Return the existing object that encapsulates BLOCK, or create a new + object. */ + +SCM +bkscm_scm_from_block (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; + + /* 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_make_block_smob (); + b_smob = (block_smob *) SCM_SMOB_DATA (b_scm); + b_smob->block = block; + b_smob->objfile = objfile; + gdbscm_fill_eqable_gsmob_ptr_slot (slot, &b_smob->base, b_scm); + + return b_scm; +} + +/* Returns the object in SELF. + Throws an exception if SELF is not a object. */ + +static SCM +bkscm_get_block_arg_unsafe (SCM self, int arg_pos, const char *func_name) +{ + SCM_ASSERT_TYPE (bkscm_is_block (self), self, arg_pos, func_name, + block_smob_name); + + return self; +} + +/* Returns a pointer to the block smob of SELF. + Throws an exception if SELF is not a object. */ + +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 object or is invalid. */ + +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, + _("")); + } + + return b_smob; +} + +/* Returns the block smob contained in SCM or NULL if SCM is not a + object. + If there is an error a 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; + + if (!bkscm_is_block (scm)) + { + *excp = gdbscm_make_type_error (func_name, arg_pos, scm, + block_smob_name); + return NULL; + } + + b_smob = (block_smob *) SCM_SMOB_DATA (scm); + if (!bkscm_is_valid (b_smob)) + { + *excp = gdbscm_make_invalid_object_error (func_name, arg_pos, scm, + _("")); + 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, then NULL is returned + and a 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? ) -> 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 ) -> 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 ) -> 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 ) -> */ + +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 != NULL) + return syscm_scm_from_symbol (sym); + return SCM_BOOL_F; +} + +/* (block-superblock ) -> */ + +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 (super_block, b_smob->objfile); + return SCM_BOOL_F; +} + +/* (block-global-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 (global_block, b_smob->objfile); +} + +/* (block-static-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 (static_block, b_smob->objfile); +} + +/* (block-global? ) -> 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? ) -> 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 ) -> list of 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 (sym); + + result = scm_cons (s_scm, result); + sym = block_iterator_next (&iter); + } + + return scm_reverse_x (result, SCM_EOL); +} + +/* The object, + for iterating over all symbols in a block. */ + +/* The smob "mark" function for . */ + +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 . */ + +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 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 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 ) -> + Return a 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 (); + + iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc); + + return iter; +} + +/* Returns the next symbol in the iteration through the block's dictionary, + or (end-of-iteration). + 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 gdbscm_end_of_iteration (); + + return syscm_scm_from_symbol (sym); +} + +/* (lookup-block address) -> + 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 (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 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 objects) in the block." }, + + { "make-block-symbols-iterator", 1, 0, 0, gdbscm_make_block_syms_iter, + "\ +Return a 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 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); +} -- cgit v1.1