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.
This commit is contained in:
Doug Evans 2014-02-09 19:40:01 -08:00
parent 7026a7c16e
commit ed3ef33944
114 changed files with 27862 additions and 28 deletions

View File

@ -1,3 +1,99 @@
2014-02-10 Doug Evans <xdje42@gmail.com>
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.
2014-02-09 Doug Evans <xdje42@gmail.com>
Revert this patch (which I approved, mea culpa).

View File

@ -280,6 +280,58 @@ SUBDIR_TUI_LDFLAGS=
SUBDIR_TUI_CFLAGS= \
-DTUI=1
# Guile sub directory definitons for guile support.
SUBDIR_GUILE_OBS = \
guile.o \
scm-arch.o \
scm-auto-load.o \
scm-block.o \
scm-breakpoint.o \
scm-disasm.o \
scm-exception.o \
scm-frame.o \
scm-iterator.o \
scm-lazy-string.o \
scm-objfile.o \
scm-math.o \
scm-ports.o \
scm-pretty-print.o \
scm-safe-call.o \
scm-gsmob.o \
scm-string.o \
scm-symbol.o \
scm-symtab.o \
scm-type.o \
scm-utils.o \
scm-value.o
SUBDIR_GUILE_SRCS = \
guile/guile.c \
guile/scm-arch.c \
guile/scm-auto-load.c \
guile/scm-block.c \
guile/scm-breakpoint.c \
guile/scm-disasm.c \
guile/scm-exception.c \
guile/scm-frame.c \
guile/scm-iterator.c \
guile/scm-lazy-string.c \
guile/scm-objfile.c \
guile/scm-math.c \
guile/scm-ports.c \
guile/scm-pretty-print.c \
guile/scm-safe-call.c \
guile/scm-gsmob.c \
guile/scm-string.c \
guile/scm-symbol.c \
guile/scm-symtab.c \
guile/scm-type.c \
guile/scm-utils.c \
guile/scm-value.c
SUBDIR_GUILE_DEPS =
SUBDIR_GUILE_LDFLAGS=
SUBDIR_GUILE_CFLAGS=
#
# python sub directory definitons
#
@ -460,7 +512,7 @@ CFLAGS = @CFLAGS@
# are sometimes a little generic, we think that the risk of collision
# with other header files is high. If that happens, we try to mitigate
# a bit the consequences by putting the Python includes last in the list.
INTERNAL_CPPFLAGS = @CPPFLAGS@ @PYTHON_CPPFLAGS@
INTERNAL_CPPFLAGS = @CPPFLAGS@ @GUILE_CPPFLAGS@ @PYTHON_CPPFLAGS@
# Need to pass this to testsuite for "make check". Probably should be
# consistent with top-level Makefile.in and gdb/testsuite/Makefile.in
@ -493,7 +545,8 @@ INTERNAL_LDFLAGS = $(CFLAGS) $(GLOBAL_CFLAGS) $(MH_LDFLAGS) $(LDFLAGS) $(CONFIG_
# XM_CLIBS, defined in *config files, have host-dependent libs.
# LIBIBERTY appears twice on purpose.
CLIBS = $(SIM) $(READLINE) $(OPCODES) $(BFD) $(INTL) $(LIBIBERTY) $(LIBDECNUMBER) \
$(XM_CLIBS) $(NAT_CLIBS) $(GDBTKLIBS) @LIBS@ @PYTHON_LIBS@ \
$(XM_CLIBS) $(NAT_CLIBS) $(GDBTKLIBS) \
@LIBS@ @GUILE_LIBS@ @PYTHON_LIBS@ \
$(LIBEXPAT) $(LIBLZMA) $(LIBBABELTRACE) \
$(LIBIBERTY) $(WIN32LIBS) $(LIBGNU)
CDEPS = $(XM_CDEPS) $(NAT_CDEPS) $(SIM) $(BFD) $(READLINE_DEPS) \
@ -1126,6 +1179,9 @@ install-strip:
`test -z '$(STRIP)' || \
echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install-only
install-guile:
$(SHELL) $(srcdir)/../mkinstalldirs $(DESTDIR)$(GDB_DATADIR)/guile/gdb
install-python:
$(SHELL) $(srcdir)/../mkinstalldirs $(DESTDIR)$(GDB_DATADIR)/python/gdb
@ -2177,7 +2233,99 @@ tui-winsource.o: $(srcdir)/tui/tui-winsource.c
$(COMPILE) $(srcdir)/tui/tui-winsource.c
$(POSTCOMPILE)
# gdb/guile dependencies
#
# Need to explicitly specify the compile rule as make will do nothing
# or try to compile the object file into the sub-directory.
guile.o: $(srcdir)/guile/guile.c
$(COMPILE) $(srcdir)/guile/guile.c
$(POSTCOMPILE)
scm-arch.o: $(srcdir)/guile/scm-arch.c
$(COMPILE) $(srcdir)/guile/scm-arch.c
$(POSTCOMPILE)
scm-auto-load.o: $(srcdir)/guile/scm-auto-load.c
$(COMPILE) $(srcdir)/guile/scm-auto-load.c
$(POSTCOMPILE)
scm-block.o: $(srcdir)/guile/scm-block.c
$(COMPILE) $(srcdir)/guile/scm-block.c
$(POSTCOMPILE)
scm-breakpoint.o: $(srcdir)/guile/scm-breakpoint.c
$(COMPILE) $(srcdir)/guile/scm-breakpoint.c
$(POSTCOMPILE)
scm-disasm.o: $(srcdir)/guile/scm-disasm.c
$(COMPILE) $(srcdir)/guile/scm-disasm.c
$(POSTCOMPILE)
scm-exception.o: $(srcdir)/guile/scm-exception.c
$(COMPILE) $(srcdir)/guile/scm-exception.c
$(POSTCOMPILE)
scm-frame.o: $(srcdir)/guile/scm-frame.c
$(COMPILE) $(srcdir)/guile/scm-frame.c
$(POSTCOMPILE)
scm-iterator.o: $(srcdir)/guile/scm-iterator.c
$(COMPILE) $(srcdir)/guile/scm-iterator.c
$(POSTCOMPILE)
scm-lazy-string.o: $(srcdir)/guile/scm-lazy-string.c
$(COMPILE) $(srcdir)/guile/scm-lazy-string.c
$(POSTCOMPILE)
scm-math.o: $(srcdir)/guile/scm-math.c
$(COMPILE) $(srcdir)/guile/scm-math.c
$(POSTCOMPILE)
scm-objfile.o: $(srcdir)/guile/scm-objfile.c
$(COMPILE) $(srcdir)/guile/scm-objfile.c
$(POSTCOMPILE)
scm-ports.o: $(srcdir)/guile/scm-ports.c
$(COMPILE) $(srcdir)/guile/scm-ports.c
$(POSTCOMPILE)
scm-pretty-print.o: $(srcdir)/guile/scm-pretty-print.c
$(COMPILE) $(srcdir)/guile/scm-pretty-print.c
$(POSTCOMPILE)
scm-safe-call.o: $(srcdir)/guile/scm-safe-call.c
$(COMPILE) $(srcdir)/guile/scm-safe-call.c
$(POSTCOMPILE)
scm-gsmob.o: $(srcdir)/guile/scm-gsmob.c
$(COMPILE) $(srcdir)/guile/scm-gsmob.c
$(POSTCOMPILE)
scm-string.o: $(srcdir)/guile/scm-string.c
$(COMPILE) $(srcdir)/guile/scm-string.c
$(POSTCOMPILE)
scm-symbol.o: $(srcdir)/guile/scm-symbol.c
$(COMPILE) $(srcdir)/guile/scm-symbol.c
$(POSTCOMPILE)
scm-symtab.o: $(srcdir)/guile/scm-symtab.c
$(COMPILE) $(srcdir)/guile/scm-symtab.c
$(POSTCOMPILE)
scm-type.o: $(srcdir)/guile/scm-type.c
$(COMPILE) $(srcdir)/guile/scm-type.c
$(POSTCOMPILE)
scm-utils.o: $(srcdir)/guile/scm-utils.c
$(COMPILE) $(srcdir)/guile/scm-utils.c
$(POSTCOMPILE)
scm-value.o: $(srcdir)/guile/scm-value.c
$(COMPILE) $(srcdir)/guile/scm-value.c
$(POSTCOMPILE)
# gdb/python/ dependencies
#
# Need to explicitly specify the compile rule as make will do nothing

View File

@ -3,8 +3,39 @@
*** Changes since GDB 7.7
* Guile scripting
GDB now has support for scripting using Guile. Whether this is
available is determined at configure time.
Guile version 2.0 or greater is required.
Guile version 2.0.9 is well tested, earlier 2.0 versions are not.
* New commands (for set/show, see "New options" below)
guile [code]
gu [code]
Invoke CODE by passing it to the Guile interpreter.
guile-repl
gr
Start a Guile interactive prompt (or "repl" for "read-eval-print loop").
info auto-load guile-scripts [regexp]
Print the list of automatically loaded Guile scripts.
* The source command is now capable of sourcing Guile scripts.
This feature is dependent on the debugger being built with Guile support.
* New options
set guile print-stack (none|message|full)
show guile print-stack
Show a stack trace when an error is encountered in a Guile script.
set auto-load guile-scripts (on|off)
show auto-load guile-scripts
Control auto-loading of Guile script files.
maint ada set ignore-descriptive-types (on|off)
maint ada show ignore-descriptive-types
Control whether the debugger should ignore descriptive types in Ada

View File

@ -39,7 +39,7 @@
#include "top.h"
#include "filestuff.h"
#include "extension.h"
#include "python/python.h"
#include "gdb/section-scripts.h"
/* The section to look in for auto-loaded scripts (in file formats that
support sections).
@ -877,18 +877,22 @@ source_section_scripts (struct objfile *objfile, const char *section_name,
char *full_path;
int opened, in_hash_table;
struct cleanup *back_to;
/* At the moment we only support python scripts in .debug_gdb_scripts,
but that can change. */
const struct extension_language_defn *language
= &extension_language_python;
const struct extension_language_defn *language;
objfile_script_sourcer_func *sourcer;
if (*p != 1)
switch (*p)
{
case SECTION_SCRIPT_ID_PYTHON_FILE:
language = get_ext_lang_defn (EXT_LANG_PYTHON);
break;
case SECTION_SCRIPT_ID_SCHEME_FILE:
language = get_ext_lang_defn (EXT_LANG_GUILE);
break;
default:
warning (_("Invalid entry in %s section"), section_name);
/* We could try various heuristics to find the next valid entry,
but it's safer to just punt. */
break;
return;
}
file = ++p;
@ -1395,6 +1399,8 @@ _initialize_auto_load (void)
{
struct cmd_list_element *cmd;
char *scripts_directory_help, *gdb_name_help, *python_name_help;
char *guile_name_help;
const char *suffix;
auto_load_pspace_data
= register_program_space_data_with_cleanup (NULL,
@ -1439,16 +1445,26 @@ Usage: info auto-load local-gdbinit"),
auto_load_dir = xstrdup (AUTO_LOAD_DIR);
suffix = ext_lang_auto_load_suffix (get_ext_lang_defn (EXT_LANG_GDB));
gdb_name_help
= xstrprintf (_("\
GDB scripts: OBJFILE%s\n"),
ext_lang_auto_load_suffix (&extension_language_gdb));
suffix);
python_name_help = NULL;
#ifdef HAVE_PYTHON
suffix = ext_lang_auto_load_suffix (get_ext_lang_defn (EXT_LANG_PYTHON));
python_name_help
= xstrprintf (_("\
Python scripts: OBJFILE%s\n"),
ext_lang_auto_load_suffix (&extension_language_python));
suffix);
#endif
guile_name_help = NULL;
#ifdef HAVE_GUILE
suffix = ext_lang_auto_load_suffix (get_ext_lang_defn (EXT_LANG_GUILE));
guile_name_help
= xstrprintf (_("\
Guile scripts: OBJFILE%s\n"),
suffix);
#endif
scripts_directory_help
= xstrprintf (_("\
@ -1456,7 +1472,7 @@ Automatically loaded scripts are located in one of the directories listed\n\
by this option.\n\
\n\
Script names:\n\
%s%s\
%s%s%s\
\n\
This option is ignored for the kinds of scripts \
having 'set auto-load ... off'.\n\
@ -1464,7 +1480,8 @@ Directories listed here need to be present also \
in the 'set auto-load safe-path'\n\
option."),
gdb_name_help,
python_name_help ? python_name_help : "");
python_name_help ? python_name_help : "",
guile_name_help ? guile_name_help : "");
add_setshow_optional_filename_cmd ("scripts-directory", class_support,
&auto_load_dir, _("\
@ -1477,6 +1494,7 @@ Show the list of directories from which to load auto-loaded scripts."),
xfree (scripts_directory_help);
xfree (python_name_help);
xfree (gdb_name_help);
xfree (guile_name_help);
auto_load_safe_path = xstrdup (AUTO_LOAD_SAFE_PATH);
auto_load_safe_path_vec_update ();

View File

@ -29,6 +29,7 @@
struct value;
struct block;
struct gdbpy_breakpoint_object;
struct gdbscm_breakpoint_object;
struct get_number_or_range_state;
struct thread_info;
struct bpstats;
@ -739,6 +740,9 @@ struct breakpoint
can sometimes be NULL for enabled GDBs as not all breakpoint
types are tracked by the scripting language API. */
struct gdbpy_breakpoint_object *py_bp_object;
/* Same as py_bp_object, but for Scheme. */
struct gdbscm_breakpoint_object *scm_bp_object;
};
/* An instance of this type is used to represent a watchpoint. It

View File

@ -1225,7 +1225,7 @@ show_user (char *args, int from_tty)
const char *comname = args;
c = lookup_cmd (&comname, cmdlist, "", 0, 1);
/* c->user_commands would be NULL if it's a python command. */
/* c->user_commands would be NULL if it's a python/scheme command. */
if (c->class != class_user || !c->user_commands)
error (_("Not a user command."));
show_user_1 (c, "", args, gdb_stdout);
@ -1831,7 +1831,7 @@ you must type \"disassemble 'foo.c'::bar\" and not \"disassemble foo.c:bar\"."))
Run the ``make'' program using the rest of the line as arguments."));
set_cmd_completer (c, filename_completer);
add_cmd ("user", no_class, show_user, _("\
Show definitions of non-python user defined commands.\n\
Show definitions of non-python/scheme user defined commands.\n\
Argument is the name of the user defined command.\n\
With no argument, show definitions of all user defined commands."), &showlist);
add_com ("apropos", class_support, apropos_command,
@ -1839,8 +1839,8 @@ With no argument, show definitions of all user defined commands."), &showlist);
add_setshow_uinteger_cmd ("max-user-call-depth", no_class,
&max_user_call_depth, _("\
Set the max call depth for non-python user-defined commands."), _("\
Show the max call depth for non-python user-defined commands."), NULL,
Set the max call depth for non-python/scheme user-defined commands."), _("\
Show the max call depth for non-python/scheme user-defined commands."), NULL,
NULL,
show_max_user_call_depth,
&setlist, &showlist);

View File

@ -91,6 +91,7 @@ multi_line_command_p (enum command_control_type type)
case while_stepping_control:
case commands_control:
case python_control:
case guile_control:
return 1;
default:
return 0;
@ -274,6 +275,19 @@ print_command_lines (struct ui_out *uiout, struct command_line *cmd,
continue;
}
if (list->control_type == guile_control)
{
ui_out_field_string (uiout, NULL, "guile");
ui_out_text (uiout, "\n");
print_command_lines (uiout, *list->body_list, depth + 1);
if (depth)
ui_out_spaces (uiout, 2 * depth);
ui_out_field_string (uiout, NULL, "end");
ui_out_text (uiout, "\n");
list = list->next;
continue;
}
/* Ignore illegal command type and try next. */
list = list->next;
} /* while (list) */
@ -589,6 +603,7 @@ execute_control_command (struct command_line *cmd)
}
case python_control:
case guile_control:
{
eval_ext_lang_from_control_command (cmd);
ret = simple_control;
@ -1028,6 +1043,11 @@ process_next_line (char *p, struct command_line **command, int parse_commands,
here. */
*command = build_command_line (python_control, "");
}
else if (p_end - p == 5 && !strncmp (p, "guile", 5))
{
/* Note that we ignore the inline "guile command" form here. */
*command = build_command_line (guile_control, "");
}
else if (p_end - p == 10 && !strncmp (p, "loop_break", 10))
{
*command = (struct command_line *)
@ -1115,7 +1135,8 @@ recurse_read_control_structure (char * (*read_next_line_func) (void),
next = NULL;
val = process_next_line (read_next_line_func (), &next,
current_cmd->control_type != python_control,
current_cmd->control_type != python_control
&& current_cmd->control_type != guile_control,
validator, closure);
/* Just skip blanks and comments. */

View File

@ -159,6 +159,9 @@
/* Define if <sys/procfs.h> has gregset_t. */
#undef HAVE_GREGSET_T
/* Define if Guile interpreter is being linked in. */
#undef HAVE_GUILE
/* Define if you have the iconv() function. */
#undef HAVE_ICONV

414
gdb/configure vendored
View File

@ -658,6 +658,9 @@ TARGET_SYSTEM_ROOT
CONFIG_LDFLAGS
RDYNAMIC
ALLOCA
GUILE_LIBS
GUILE_CPPFLAGS
pkg_config_prog_path
PYTHON_LIBS
PYTHON_CPPFLAGS
PYTHON_CFLAGS
@ -813,6 +816,7 @@ with_gnu_ld
enable_rpath
with_libexpat_prefix
with_python
with_guile
enable_libmcheck
with_included_regex
with_sysroot
@ -1530,6 +1534,8 @@ Optional Packages:
--without-libexpat-prefix don't search for libexpat in includedir and libdir
--with-python[=PYTHON] include python support
(auto/yes/no/<python-program>)
--with-guile[=GUILE] include guile support
(auto/yes/no/<guile-version>/<pkg-config-program>)
--without-included-regex
don't use included regex; this is the default on
systems with version 2 of the GNU C library (use
@ -8681,6 +8687,414 @@ fi
# -------------------- #
# Check for libguile. #
# -------------------- #
# Extract the first word of "pkg-config", so it can be a program name with args.
set dummy pkg-config; ac_word=$2
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
$as_echo_n "checking for $ac_word... " >&6; }
if test "${ac_cv_path_pkg_config_prog_path+set}" = set; then :
$as_echo_n "(cached) " >&6
else
case $pkg_config_prog_path in
[\\/]* | ?:[\\/]*)
ac_cv_path_pkg_config_prog_path="$pkg_config_prog_path" # Let the user override the test with a path.
;;
*)
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
ac_cv_path_pkg_config_prog_path="$as_dir/$ac_word$ac_exec_ext"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
test -z "$ac_cv_path_pkg_config_prog_path" && ac_cv_path_pkg_config_prog_path="missing"
;;
esac
fi
pkg_config_prog_path=$ac_cv_path_pkg_config_prog_path
if test -n "$pkg_config_prog_path"; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $pkg_config_prog_path" >&5
$as_echo "$pkg_config_prog_path" >&6; }
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
fi
# Check whether --with-guile was given.
if test "${with_guile+set}" = set; then :
withval=$with_guile;
else
with_guile=auto
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use guile" >&5
$as_echo_n "checking whether to use guile... " >&6; }
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $with_guile" >&5
$as_echo "$with_guile" >&6; }
try_guile_versions="guile-2.0"
have_libguile=no
case "${with_guile}" in
no)
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: guile support disabled; some features will be unavailable." >&5
$as_echo "$as_me: WARNING: guile support disabled; some features will be unavailable." >&2;}
;;
auto)
pkg_config=${pkg_config_prog_path}
guile_version_list=${try_guile_versions}
flag_errors=no
if test "${pkg_config}" = "missing"; then
as_fn_error "pkg-config program not found" "$LINENO" 5
fi
if test ! -f "${pkg_config}"; then
as_fn_error "pkg-config program ${pkg_config} not found" "$LINENO" 5
fi
found_usable_guile=checking
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for usable guile from ${pkg_config}" >&5
$as_echo_n "checking for usable guile from ${pkg_config}... " >&6; }
for guile_version in ${guile_version_list}; do
${pkg_config} --exists ${guile_version} 2>/dev/null
if test $? != 0; then
continue
fi
new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
if test $? != 0; then
as_fn_error "failure running pkg-config --cflags ${guile_version}" "$LINENO" 5
fi
new_LIBS=`${pkg_config} --libs ${guile_version}`
if test $? != 0; then
as_fn_error "failure running pkg-config --libs ${guile_version}" "$LINENO" 5
fi
found_usable_guile=${guile_version}
break
done
if test "${found_usable_guile}" = "checking"; then
if test "${flag_errors}" = "yes"; then
as_fn_error "unable to find usable guile version from \"${guile_version_list}\"" "$LINENO" 5
else
found_usable_guile=no
fi
fi
if test "${found_usable_guile}" != no; then
save_CPPFLAGS=$CPPFLAGS
save_LIBS=$LIBS
CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
LIBS="$LIBS $new_LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include "libguile.h"
int
main ()
{
scm_init_guile ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
have_libguile=yes
GUILE_CPPFLAGS=$new_CPPFLAGS
GUILE_LIBS=$new_LIBS
else
found_usable_guile=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
CPPFLAGS=$save_CPPFLAGS
LIBS=$save_LIBS
if test "${found_usable_guile}" = no; then
if test "${flag_errors}" = yes; then
{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error "linking guile version ${guile_version} test program failed
See \`config.log' for more details." "$LINENO" 5; }
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: ${found_usable_guile}" >&5
$as_echo "${found_usable_guile}" >&6; }
;;
yes)
pkg_config=${pkg_config_prog_path}
guile_version_list=${try_guile_versions}
flag_errors=yes
if test "${pkg_config}" = "missing"; then
as_fn_error "pkg-config program not found" "$LINENO" 5
fi
if test ! -f "${pkg_config}"; then
as_fn_error "pkg-config program ${pkg_config} not found" "$LINENO" 5
fi
found_usable_guile=checking
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for usable guile from ${pkg_config}" >&5
$as_echo_n "checking for usable guile from ${pkg_config}... " >&6; }
for guile_version in ${guile_version_list}; do
${pkg_config} --exists ${guile_version} 2>/dev/null
if test $? != 0; then
continue
fi
new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
if test $? != 0; then
as_fn_error "failure running pkg-config --cflags ${guile_version}" "$LINENO" 5
fi
new_LIBS=`${pkg_config} --libs ${guile_version}`
if test $? != 0; then
as_fn_error "failure running pkg-config --libs ${guile_version}" "$LINENO" 5
fi
found_usable_guile=${guile_version}
break
done
if test "${found_usable_guile}" = "checking"; then
if test "${flag_errors}" = "yes"; then
as_fn_error "unable to find usable guile version from \"${guile_version_list}\"" "$LINENO" 5
else
found_usable_guile=no
fi
fi
if test "${found_usable_guile}" != no; then
save_CPPFLAGS=$CPPFLAGS
save_LIBS=$LIBS
CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
LIBS="$LIBS $new_LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include "libguile.h"
int
main ()
{
scm_init_guile ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
have_libguile=yes
GUILE_CPPFLAGS=$new_CPPFLAGS
GUILE_LIBS=$new_LIBS
else
found_usable_guile=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
CPPFLAGS=$save_CPPFLAGS
LIBS=$save_LIBS
if test "${found_usable_guile}" = no; then
if test "${flag_errors}" = yes; then
{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error "linking guile version ${guile_version} test program failed
See \`config.log' for more details." "$LINENO" 5; }
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: ${found_usable_guile}" >&5
$as_echo "${found_usable_guile}" >&6; }
;;
[\\/]* | ?:[\\/]*)
pkg_config=${with_guile}
guile_version_list=${try_guile_versions}
flag_errors=yes
if test "${pkg_config}" = "missing"; then
as_fn_error "pkg-config program not found" "$LINENO" 5
fi
if test ! -f "${pkg_config}"; then
as_fn_error "pkg-config program ${pkg_config} not found" "$LINENO" 5
fi
found_usable_guile=checking
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for usable guile from ${pkg_config}" >&5
$as_echo_n "checking for usable guile from ${pkg_config}... " >&6; }
for guile_version in ${guile_version_list}; do
${pkg_config} --exists ${guile_version} 2>/dev/null
if test $? != 0; then
continue
fi
new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
if test $? != 0; then
as_fn_error "failure running pkg-config --cflags ${guile_version}" "$LINENO" 5
fi
new_LIBS=`${pkg_config} --libs ${guile_version}`
if test $? != 0; then
as_fn_error "failure running pkg-config --libs ${guile_version}" "$LINENO" 5
fi
found_usable_guile=${guile_version}
break
done
if test "${found_usable_guile}" = "checking"; then
if test "${flag_errors}" = "yes"; then
as_fn_error "unable to find usable guile version from \"${guile_version_list}\"" "$LINENO" 5
else
found_usable_guile=no
fi
fi
if test "${found_usable_guile}" != no; then
save_CPPFLAGS=$CPPFLAGS
save_LIBS=$LIBS
CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
LIBS="$LIBS $new_LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include "libguile.h"
int
main ()
{
scm_init_guile ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
have_libguile=yes
GUILE_CPPFLAGS=$new_CPPFLAGS
GUILE_LIBS=$new_LIBS
else
found_usable_guile=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
CPPFLAGS=$save_CPPFLAGS
LIBS=$save_LIBS
if test "${found_usable_guile}" = no; then
if test "${flag_errors}" = yes; then
{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error "linking guile version ${guile_version} test program failed
See \`config.log' for more details." "$LINENO" 5; }
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: ${found_usable_guile}" >&5
$as_echo "${found_usable_guile}" >&6; }
;;
"" | */*)
# Disallow --with=guile="" and --with-guile=foo/bar.
as_fn_error "invalid value for --with-guile" "$LINENO" 5
;;
*)
# A space separate list of guile versions to try, in order.
pkg_config=${pkg_config_prog_path}
guile_version_list=${with_guile}
flag_errors=yes
if test "${pkg_config}" = "missing"; then
as_fn_error "pkg-config program not found" "$LINENO" 5
fi
if test ! -f "${pkg_config}"; then
as_fn_error "pkg-config program ${pkg_config} not found" "$LINENO" 5
fi
found_usable_guile=checking
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for usable guile from ${pkg_config}" >&5
$as_echo_n "checking for usable guile from ${pkg_config}... " >&6; }
for guile_version in ${guile_version_list}; do
${pkg_config} --exists ${guile_version} 2>/dev/null
if test $? != 0; then
continue
fi
new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
if test $? != 0; then
as_fn_error "failure running pkg-config --cflags ${guile_version}" "$LINENO" 5
fi
new_LIBS=`${pkg_config} --libs ${guile_version}`
if test $? != 0; then
as_fn_error "failure running pkg-config --libs ${guile_version}" "$LINENO" 5
fi
found_usable_guile=${guile_version}
break
done
if test "${found_usable_guile}" = "checking"; then
if test "${flag_errors}" = "yes"; then
as_fn_error "unable to find usable guile version from \"${guile_version_list}\"" "$LINENO" 5
else
found_usable_guile=no
fi
fi
if test "${found_usable_guile}" != no; then
save_CPPFLAGS=$CPPFLAGS
save_LIBS=$LIBS
CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
LIBS="$LIBS $new_LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include "libguile.h"
int
main ()
{
scm_init_guile ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
have_libguile=yes
GUILE_CPPFLAGS=$new_CPPFLAGS
GUILE_LIBS=$new_LIBS
else
found_usable_guile=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
CPPFLAGS=$save_CPPFLAGS
LIBS=$save_LIBS
if test "${found_usable_guile}" = no; then
if test "${flag_errors}" = yes; then
{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
as_fn_error "linking guile version ${guile_version} test program failed
See \`config.log' for more details." "$LINENO" 5; }
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: ${found_usable_guile}" >&5
$as_echo "${found_usable_guile}" >&6; }
;;
esac
if test "${have_libguile}" != no; then
$as_echo "#define HAVE_GUILE 1" >>confdefs.h
CONFIG_OBS="$CONFIG_OBS \$(SUBDIR_GUILE_OBS)"
CONFIG_DEPS="$CONFIG_DEPS \$(SUBDIR_GUILE_DEPS)"
CONFIG_SRCS="$CONFIG_SRCS \$(SUBDIR_GUILE_SRCS)"
CONFIG_INSTALL="$CONFIG_INSTALL install-guile"
ENABLE_CFLAGS="$ENABLE_CFLAGS \$(SUBDIR_GUILE_CFLAGS)"
else
# Even if Guile support is not compiled in, we need to have these files
# included.
CONFIG_OBS="$CONFIG_OBS guile.o"
CONFIG_SRCS="$CONFIG_SRCS guile/guile.c"
fi
# --------------------- #
# Check for libmcheck. #
# --------------------- #

View File

@ -1054,6 +1054,154 @@ AC_SUBST(PYTHON_CFLAGS)
AC_SUBST(PYTHON_CPPFLAGS)
AC_SUBST(PYTHON_LIBS)
# -------------------- #
# Check for libguile. #
# -------------------- #
dnl We check guile with pkg-config.
AC_PATH_PROG(pkg_config_prog_path, pkg-config, missing)
dnl Utility to simplify finding libguile.
dnl $1 = pkg-config-program
dnl $2 = space-separate list of guile versions to try
dnl $3 = yes|no, indicating whether to flag errors or ignore them
dnl $4 = the shell variable to assign the result to
dnl If libguile is found we store "yes" here.
AC_DEFUN([AC_TRY_LIBGUILE],
[
pkg_config=$1
guile_version_list=$2
flag_errors=$3
define([have_libguile_var],$4)
if test "${pkg_config}" = "missing"; then
AC_ERROR(pkg-config program not found)
fi
if test ! -f "${pkg_config}"; then
AC_ERROR(pkg-config program ${pkg_config} not found)
fi
found_usable_guile=checking
AC_MSG_CHECKING([for usable guile from ${pkg_config}])
for guile_version in ${guile_version_list}; do
${pkg_config} --exists ${guile_version} 2>/dev/null
if test $? != 0; then
continue
fi
dnl pkg-config says the package exists, so if we get an error now,
dnl that's bad.
new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
if test $? != 0; then
AC_ERROR(failure running pkg-config --cflags ${guile_version})
fi
new_LIBS=`${pkg_config} --libs ${guile_version}`
if test $? != 0; then
AC_ERROR(failure running pkg-config --libs ${guile_version})
fi
dnl If we get this far, great.
found_usable_guile=${guile_version}
break
done
if test "${found_usable_guile}" = "checking"; then
if test "${flag_errors}" = "yes"; then
AC_ERROR(unable to find usable guile version from "${guile_version_list}")
else
found_usable_guile=no
fi
fi
dnl One final sanity check.
dnl The user could have said --with-guile=python-2.7.
if test "${found_usable_guile}" != no; then
save_CPPFLAGS=$CPPFLAGS
save_LIBS=$LIBS
CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
LIBS="$LIBS $new_LIBS"
AC_LINK_IFELSE(AC_LANG_PROGRAM([[#include "libguile.h"]],
[[scm_init_guile ();]]),
[have_libguile_var=yes
GUILE_CPPFLAGS=$new_CPPFLAGS
GUILE_LIBS=$new_LIBS],
[found_usable_guile=no])
CPPFLAGS=$save_CPPFLAGS
LIBS=$save_LIBS
if test "${found_usable_guile}" = no; then
if test "${flag_errors}" = yes; then
AC_MSG_FAILURE(linking guile version ${guile_version} test program failed)
fi
fi
fi
AC_MSG_RESULT([${found_usable_guile}])
])
dnl There are several different values for --with-guile:
dnl
dnl no - Don't include guile support.
dnl yes - Include guile support, error if it's missing.
dnl The pkg-config program must be in $PATH.
dnl auto - Same as "yes", but if guile is missing from the system,
dnl fall back to "no".
dnl guile-version [guile-version-choice-2 ...] -
dnl A space-separated list of guile package versions to try.
dnl These are passed to pkg-config as-is.
dnl E.g., guile-2.0 or guile-2.2-uninstalled
dnl This requires making sure PKG_CONFIG_PATH is set appropriately.
dnl /path/to/pkg-config -
dnl Use this pkg-config program.
dnl NOTE: This needn't be the "real" pkg-config program.
dnl It could be a shell script. It is invoked as:
dnl pkg-config --exists $version
dnl pkg-config --cflags $version
dnl pkg-config --libs $version
dnl $version will be the default guile version (currently guile-2.0),
dnl but the program is free to ignore this.
AC_ARG_WITH(guile,
AS_HELP_STRING([--with-guile@<:@=GUILE@:>@], [include guile support (auto/yes/no/<guile-version>/<pkg-config-program>)]),
[], [with_guile=auto])
AC_MSG_CHECKING([whether to use guile])
AC_MSG_RESULT([$with_guile])
try_guile_versions="guile-2.0"
have_libguile=no
case "${with_guile}" in
no)
AC_MSG_WARN([guile support disabled; some features will be unavailable.])
;;
auto)
AC_TRY_LIBGUILE(${pkg_config_prog_path}, ${try_guile_versions}, no, have_libguile)
;;
yes)
AC_TRY_LIBGUILE(${pkg_config_prog_path}, ${try_guile_versions}, yes, have_libguile)
;;
[[\\/]]* | ?:[[\\/]]*)
AC_TRY_LIBGUILE(${with_guile}, ${try_guile_versions}, yes, have_libguile)
;;
"" | */*)
# Disallow --with=guile="" and --with-guile=foo/bar.
AC_ERROR(invalid value for --with-guile)
;;
*)
# A space separate list of guile versions to try, in order.
AC_TRY_LIBGUILE(${pkg_config_prog_path}, ${with_guile}, yes, have_libguile)
;;
esac
if test "${have_libguile}" != no; then
AC_DEFINE(HAVE_GUILE, 1, [Define if Guile interpreter is being linked in.])
CONFIG_OBS="$CONFIG_OBS \$(SUBDIR_GUILE_OBS)"
CONFIG_DEPS="$CONFIG_DEPS \$(SUBDIR_GUILE_DEPS)"
CONFIG_SRCS="$CONFIG_SRCS \$(SUBDIR_GUILE_SRCS)"
CONFIG_INSTALL="$CONFIG_INSTALL install-guile"
ENABLE_CFLAGS="$ENABLE_CFLAGS \$(SUBDIR_GUILE_CFLAGS)"
else
# Even if Guile support is not compiled in, we need to have these files
# included.
CONFIG_OBS="$CONFIG_OBS guile.o"
CONFIG_SRCS="$CONFIG_SRCS guile/guile.c"
fi
AC_SUBST(GUILE_CPPFLAGS)
AC_SUBST(GUILE_LIBS)
# --------------------- #
# Check for libmcheck. #
# --------------------- #

View File

@ -19,8 +19,9 @@
srcdir = @srcdir@
SYSCALLS_SRCDIR = $(srcdir)/../syscalls
PYTHON_SRCDIR = $(srcdir)/../python/lib
GUILE_SRCDIR = $(srcdir)/../guile/lib
SYSTEM_GDBINIT_SRCDIR = $(srcdir)/../system-gdbinit
VPATH = $(srcdir):$(SYSCALLS_SRCDIR):$(PYTHON_SRCDIR):$(SYSTEM_GDBINIT_SRCDIR)
VPATH = $(srcdir):$(SYSCALLS_SRCDIR):$(PYTHON_SRCDIR):$(GUILE_SRCDIR):$(SYSTEM_GDBINIT_SRCDIR)
top_srcdir = @top_srcdir@
top_builddir = @top_builddir@
@ -72,6 +73,17 @@ PYTHON_FILES = \
gdb/function/__init__.py \
gdb/function/strfns.py
GUILE_DIR = guile
GUILE_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(GUILE_DIR)
GUILE_FILES = \
./gdb.scm \
gdb/boot.scm \
gdb/experimental.scm \
gdb/init.scm \
gdb/iterator.scm \
gdb/printing.scm \
gdb/types.scm
SYSTEM_GDBINIT_DIR = system-gdbinit
SYSTEM_GDBINIT_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(SYSTEM_GDBINIT_DIR)
SYSTEM_GDBINIT_FILES = \
@ -111,7 +123,7 @@ FLAGS_TO_PASS = \
"RUNTESTFLAGS=$(RUNTESTFLAGS)"
.PHONY: all
all: stamp-syscalls stamp-python stamp-system-gdbinit
all: stamp-syscalls stamp-python stamp-guile stamp-system-gdbinit
# For portability's sake, we need to handle systems that don't have
# symbolic links.
@ -195,6 +207,43 @@ uninstall-python:
done \
done
stamp-guile: Makefile $(GUILE_FILES)
rm -rf ./$(GUILE_DIR)
files='$(GUILE_FILES)' ; \
for file in $$files ; do \
dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
$(INSTALL_DIR) ./$(GUILE_DIR)/$$dir ; \
$(INSTALL_DATA) $(GUILE_SRCDIR)/$$file ./$(GUILE_DIR)/$$dir ; \
done
touch $@
.PHONY: clean-guile
clean-guile:
rm -rf $(GUILE_DIR)
rm -f stamp-guile
.PHONY: install-guile
install-guile:
files='$(GUILE_FILES)' ; \
for file in $$files ; do \
dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
$(INSTALL_DIR) $(GUILE_INSTALL_DIR)/$$dir ; \
$(INSTALL_DATA) ./$(GUILE_DIR)/$$file $(GUILE_INSTALL_DIR)/$$dir ; \
done
.PHONY: uninstall-guile
uninstall-guile:
files='$(GUILE_FILES)' ; \
for file in $$files ; do \
slashdir=`echo "/$$file" | sed 's,/[^/]*$$,,'` ; \
rm -f $(GUILE_INSTALL_DIR)/$$file ; \
while test "x$$file" != "x$$slashdir" ; do \
rmdir 2>/dev/null "$(GUILE_INSTALL_DIR)$$slashdir" ; \
file="$$slashdir" ; \
slashdir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
done \
done
stamp-system-gdbinit: Makefile $(SYSTEM_GDBINIT_FILES)
rm -rf ./$(SYSTEM_GDBINIT_DIR)
mkdir ./$(SYSTEM_GDBINIT_DIR)
@ -246,13 +295,15 @@ install: all
@$(MAKE) $(FLAGS_TO_PASS) install-only
.PHONY: install-only
install-only: install-syscalls install-python install-system-gdbinit
install-only: install-syscalls install-python install-guile \
install-system-gdbinit
.PHONY: uninstall
uninstall: uninstall-syscalls uninstall-python uninstall-system-gdbinit
uninstall: uninstall-syscalls uninstall-python uninstall-guile \
uninstall-system-gdbinit
.PHONY: clean
clean: clean-syscalls clean-python clean-system-gdbinit
clean: clean-syscalls clean-python clean-guile clean-system-gdbinit
.PHONY: maintainer-clean realclean distclean
maintainer-clean realclean distclean: clean

View File

@ -411,6 +411,7 @@ enum command_control_type
if_control,
commands_control,
python_control,
guile_control,
while_stepping_control,
invalid_control
};

View File

@ -376,7 +376,7 @@ fprintf_disasm (void *stream, const char *format, ...)
return 0;
}
static struct disassemble_info
struct disassemble_info
gdb_disassemble_info (struct gdbarch *gdbarch, struct ui_file *file)
{
struct disassemble_info di;

View File

@ -19,15 +19,23 @@
#ifndef DISASM_H
#define DISASM_H
#include "dis-asm.h"
#define DISASSEMBLY_SOURCE (0x1 << 0)
#define DISASSEMBLY_RAW_INSN (0x1 << 1)
#define DISASSEMBLY_OMIT_FNAME (0x1 << 2)
#define DISASSEMBLY_FILENAME (0x1 << 3)
#define DISASSEMBLY_OMIT_PC (0x1 << 4)
struct gdbarch;
struct ui_out;
struct ui_file;
/* Return a filled in disassemble_info object for use by gdb. */
extern struct disassemble_info gdb_disassemble_info (struct gdbarch *gdbarch,
struct ui_file *file);
extern void gdb_disassembly (struct gdbarch *gdbarch, struct ui_out *uiout,
char *file_string, int flags, int how_many,
CORE_ADDR low, CORE_ADDR high);

View File

@ -1,3 +1,14 @@
2014-02-10 Doug Evans <xdje42@gmail.com>
* 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.
2014-01-28 Joel Brobecker <brobecker@adacore.com>
* gdb.texinfo (Ada Glitches): Document the new "maint ada set/show

View File

@ -130,6 +130,7 @@ GDB_DOC_BUILD_INCLUDES = \
GDBvn.texi
GDB_DOC_FILES = \
$(srcdir)/gdb.texinfo \
$(srcdir)/guile.texi \
$(GDB_DOC_SOURCE_INCLUDES) \
$(GDB_DOC_BUILD_INCLUDES)

View File

@ -22324,6 +22324,12 @@ These are @value{GDBN} control commands for the auto-loading:
@tab Show setting of @value{GDBN} Python scripts.
@item @xref{info auto-load python-scripts}.
@tab Show state of @value{GDBN} Python scripts.
@item @xref{set auto-load guile-scripts}.
@tab Control for @value{GDBN} Guile scripts.
@item @xref{show auto-load guile-scripts}.
@tab Show setting of @value{GDBN} Guile scripts.
@item @xref{info auto-load guile-scripts}.
@tab Show state of @value{GDBN} Guile scripts.
@item @xref{set auto-load scripts-directory}.
@tab Control for @value{GDBN} auto-loaded scripts location.
@item @xref{show auto-load scripts-directory}.
@ -22950,7 +22956,9 @@ being debugged.
@menu
* Sequences:: Canned Sequences of @value{GDBN} Commands
* Python:: Extending @value{GDBN} using Python
* Guile:: Extending @value{GDBN} using Guile
* Auto-loading extensions:: Automatically loading extensions
* Multiple Extension Languages:: Working with multiple extension languages
* Aliases:: Creating new spellings of existing commands
@end menu
@ -27953,6 +27961,9 @@ substitute_prompt (``frame: \f,
@end smallexample
@end table
@c Guile docs live in a separate file.
@include guile.texi
@node Auto-loading extensions
@section Auto-loading extensions
@cindex auto-loading extensions
@ -27998,6 +28009,8 @@ where @var{ext} is the file extension for the extension language:
GDB's own command language
@item @file{@var{objfile}-gdb.py}
Python
@item @file{@var{objfile}-gdb.scm}
Guile
@end table
@var{script-name} is formed by ensuring that the file name of @var{objfile}
@ -28091,6 +28104,7 @@ for example, this GCC macro for Python scripts.
@end example
@noindent
For Guile scripts, replace @code{.byte 1} with @code{.byte 3}.
Then one can reference the macro in a header or source file like this:
@example
@ -28162,6 +28176,26 @@ cumbersome. It may be easier to specify the scripts in the
top of the source tree to the source search path.
@end itemize
@node Multiple Extension Languages
@section Multiple Extension Languages
The Guile and Python extension languages do not share any state,
and generally do not interfere with each other.
There are some things to be aware of, however.
@subsection Python comes first
Python was @value{GDBN}'s first extension language, and to avoid breaking
existing behaviour Python comes first. This is generally solved by the
``first one wins'' principle. @value{GDBN} maintains a list of enabled
extension languages, and when it makes a call to an extension language,
(say to pretty-print a value), it tries each in turn until an extension
language indicates it has performed the request (e.g., has returned the
pretty-printed form of a value).
This extends to errors while performing such requests: If an error happens
while, for example, trying to pretty-print an object then the error is
reported and any following extension languages are not tried.
@node Aliases
@section Creating new spellings of existing commands
@cindex aliases for commands

3278
gdb/doc/guile.texi Normal file

File diff suppressed because it is too large Load Diff

View File

@ -30,6 +30,7 @@
#include "observer.h"
#include "cli/cli-script.h"
#include "python/python.h"
#include "guile/guile.h"
/* Iterate over all external extension languages, regardless of whether the
support has been compiled in or not.
@ -100,6 +101,7 @@ static const struct extension_language_defn * const extension_languages[] =
{
/* To preserve existing behaviour, python should always appear first. */
&extension_language_python,
&extension_language_guile,
NULL
};

View File

@ -53,7 +53,8 @@ enum extension_language
{
EXT_LANG_NONE,
EXT_LANG_GDB,
EXT_LANG_PYTHON
EXT_LANG_PYTHON,
EXT_LANG_GUILE
};
/* Extension language frame-filter status return values. */

View File

@ -1446,6 +1446,40 @@ lookup_struct_elt_type (struct type *type, const char *name, int noerr)
error (_("Type %s has no component named %s."), typename, name);
}
/* Store in *MAX the largest number representable by unsigned integer type
TYPE. */
void
get_unsigned_type_max (struct type *type, ULONGEST *max)
{
unsigned int n;
CHECK_TYPEDEF (type);
gdb_assert (TYPE_CODE (type) == TYPE_CODE_INT && TYPE_UNSIGNED (type));
gdb_assert (TYPE_LENGTH (type) <= sizeof (ULONGEST));
/* Written this way to avoid overflow. */
n = TYPE_LENGTH (type) * TARGET_CHAR_BIT;
*max = ((((ULONGEST) 1 << (n - 1)) - 1) << 1) | 1;
}
/* Store in *MIN, *MAX the smallest and largest numbers representable by
signed integer type TYPE. */
void
get_signed_type_minmax (struct type *type, LONGEST *min, LONGEST *max)
{
unsigned int n;
CHECK_TYPEDEF (type);
gdb_assert (TYPE_CODE (type) == TYPE_CODE_INT && !TYPE_UNSIGNED (type));
gdb_assert (TYPE_LENGTH (type) <= sizeof (LONGEST));
n = TYPE_LENGTH (type) * TARGET_CHAR_BIT;
*min = -((ULONGEST) 1 << (n - 1));
*max = ((ULONGEST) 1 << (n - 1)) - 1;
}
/* Lookup the vptr basetype/fieldno values for TYPE.
If found store vptr_basetype in *BASETYPEP if non-NULL, and return
vptr_fieldno. Also, if found and basetype is from the same objfile,

View File

@ -1545,6 +1545,10 @@ extern struct type *lookup_unsigned_typename (const struct language_defn *,
extern struct type *lookup_signed_typename (const struct language_defn *,
struct gdbarch *, const char *);
extern void get_unsigned_type_max (struct type *, ULONGEST *);
extern void get_signed_type_minmax (struct type *, LONGEST *, LONGEST *);
extern struct type *check_typedef (struct type *);
#define CHECK_TYPEDEF(TYPE) \

229
gdb/guile/README Normal file
View File

@ -0,0 +1,229 @@
README for gdb/guile
====================
This file contains important notes for gdb/guile developers.
["gdb/guile" refers to the directory you found this file in]
Nomenclature:
In the implementation we use "Scheme" or "Guile" depending on context.
And sometimes it doesn't matter.
Guile is Scheme, and for the most part this is what we present to the user
as well. However, to highlight the fact that it is Guile, the GDB commands
that invoke Scheme functions are named "guile" and "guile-repl",
abbreviated "gu" and "gr" respectively.
Co-existence with Python:
Keep the user interfaces reasonably consistent, but don't shy away from
providing a clearer (or more Scheme-friendly/consistent) user interface
where appropriate.
Additions to Python support or Scheme support don't require corresponding
changes in the other scripting language.
Scheme-wrapped breakpoints are created lazily so that if the user
doesn't use Scheme s/he doesn't pay any cost.
Importing the gdb module into Scheme:
To import the gdb module:
(gdb) guile (use-modules (gdb))
If you want to add a prefix to gdb module symbols:
(gdb) guile (use-modules ((gdb) #:renamer (symbol-prefix-proc 'gdb:)))
This gives every symbol a "gdb:" prefix which is a common convention.
OTOH it's more to type.
Implementation/Hacking notes:
Don't use scm_is_false.
For this C function, () == #f (a la Lisp) and it's not clear how treating
them as equivalent for truth values will affect the GDB interface.
Until the effect is clear avoid them.
Instead use gdbscm_is_false, gdbscm_is_true, gdbscm_is_bool.
There are macros in guile-internal.h to enforce this.
Use gdbscm_foo as the name of functions that implement Scheme procedures
to provide consistent naming in error messages. The user can see "gdbscm"
in the name and immediately know where the function came from.
All smobs contain gdb_smob or chained_gdb_smob as the first member.
This provides a mechanism for extending them in the Scheme side without
tying GDB to the details.
The lifetime of a smob, AIUI, is decided by the containing SCM.
When there is no longer a reference to the containing SCM then the
smob can be GC'd. Objects that have references from outside of Scheme,
e.g., breakpoints, need to be protected from GC.
Don't do something that can cause a Scheme exception inside a TRY_CATCH,
and, in code that can be called from Scheme, don't do something that can
cause a GDB exception outside a TRY_CATCH.
This makes the code a little tricky to write sometimes, but it is a
rule imposed by the programming environment. Bugs often happen because
this rule is broken. Learn it, follow it.
Coding style notes:
- If you find violations to these rules, let's fix the code.
Some attempt has been made to be consistent, but it's early.
Over time we want things to be more consistent, not less.
- None of this really needs to be read. Instead, do not be creative:
Monkey-See-Monkey-Do hacking should generally Just Work.
- Absence of the word "typically" means the rule is reasonably strict.
- The gdbscm_initialize_foo function (e.g., gdbscm_initialize_values)
is the last thing to appear in the file, immediately preceded by any
tables of exported variables and functions.
- In addition to these of course, follow GDB coding conventions.
General naming rules:
- The word "object" absent any modifier (like "GOOPS object") means a
Scheme object (of any type), and is never used otherwise.
If you want to refer to, e.g., a GOOPS object, say "GOOPS object".
- Do not begin any function, global variable, etc. name with scm_.
That's what the Guile implementation uses.
(kinda obvious, just being complete).
- The word "invalid" carries a specific connotation. Try not to use it
in a different way. It means the underlying GDB object has disappeared.
For example, a <gdb:objfile> smob becomes "invalid" when the underlying
objfile is removed from GDB.
- We typically use the word "exception" to mean Scheme exceptions,
and we typically use the word "error" to mean GDB errors.
Comments:
- function comments for functions implementing Scheme procedures begin with
a description of the Scheme usage. Example:
/* (gsmob-aux gsmob) -> object */
- the following comment appears after the copyright header:
/* See README file in this directory for implementation notes, coding
conventions, et.al. */
Smob naming:
- gdb smobs are named, internally, "gdb:foo"
- in Guile they become <gdb:foo>, that is the convention for naming classes
and smobs have rudimentary GOOPS support (they can't be inherited from,
but generics can work with them)
- in comments use the Guile naming for smobs,
i.e., <gdb:foo> instead of gdb:foo.
Note: This only applies to smobs. Exceptions are also named gdb:foo,
but since they are not "classes" they are not wrapped in <>.
- smob names are stored in a global, and for simplicity we pass this
global as the "expected type" parameter to SCM_ASSERT_TYPE, thus in
this instance smob types are printed without the <>.
[Hmmm, this rule seems dated now. Plus I18N rules in GDB are not always
clear, sometimes we pass the smob name through _(), however it's not
clear that's actually a good idea.]
Type naming:
- smob structs are typedefs named foo_smob
Variable naming:
- "scm" by itself is reserved for arbitrary Scheme objects
- variables that are pointers to smob structs are named <char>_smob or
<char><char>_smob, e.g., f_smob for a pointer to a frame smob
- variables that are gdb smob objects are typically named <char>_scm or
<char><char>_scm, e.g., f_scm for a <gdb:frame> object
- the name of the first argument for method-like functions is "self"
Function naming:
General:
- all non-static functions have a prefix,
either gdbscm_ or <char><char>scm_ [or <char><char><char>scm_]
- all functions that implement Scheme procedures have a gdbscm_ prefix,
this is for consistency and readability of Scheme exception text
- static functions typically have a prefix
- the prefix is typically <char><char>scm_ where the first two letters
are unique to the file or class the function works with.
E.g., the scm-arch.c prefix is arscm_.
This follows something used in gdb/python in some places,
we make it formal.
- if the function is of a general nature, or no other prefix works,
use gdbscm_
Conversion functions:
- the from/to in function names follows from libguile's existing style
- conversions from/to Scheme objects are named:
prefix_scm_from_foo: converts from foo to scm
prefix_scm_to_foo: converts from scm to foo
Exception handling:
- functions that may throw a Scheme exception have an _unsafe suffix
- This does not apply to functions that implement Scheme procedures.
- This does not apply to functions whose explicit job is to throw
an exception. Adding _unsafe to gdbscm_throw is kinda superfluous. :-)
- functions that can throw a GDB error aren't adorned with _unsafe
- "_safe" in a function name means it will never throw an exception
- Generally unnecessary, since the convention is to mark the ones that
*can* throw an exception. But sometimes it's useful to highlight the
fact that the function is safe to call without worrying about exception
handling.
- except for functions that implement Scheme procedures, all functions
that can throw exceptions (GDB or Scheme) say so in their function comment
- functions that don't throw an exception, but still need to indicate to
the caller that one happened (i.e., "safe" functions), either return
a <gdb:exception> smob as a result or pass it back via a parameter.
For this reason don't pass back <gdb:exception> smobs for any other
reason. There are functions that explicitly construct <gdb:exception>
smobs. They're obviously the, umm, exception.
Internal functions:
- internal Scheme functions begin with "%" and are intentionally undocumented
in the manual
Standard Guile/Scheme conventions:
- predicates that return Scheme values have the suffix _p and have suffix "?"
in the Scheme procedure's name
- functions that implement Scheme procedures that modify state have the
suffix _x and have suffix "!" in the Scheme procedure's name
- object predicates that return a C truth value are named prefix_is_foo
- functions that set something have "set" at the front (except for a prefix)
write this: gdbscm_set_gsmob_aux_x implements (set-gsmob-aux! ...)
not this: gdbscm_gsmob_set_aux_x implements (gsmob-set-aux! ...)
Doc strings:
- there are lots of existing examples, they should be pretty consistent,
use them as boilerplate/examples
- begin with a one line summary (can be multiple lines if necessary)
- if the arguments need description:
- blank line
- " Arguments: arg1 arg2"
" arg1: blah ..."
" arg2: blah ..."
- if the result requires more description:
- blank line
- " Returns:"
" Blah ..."
- if it's important to list exceptions that can be thrown:
- blank line
- " Throws:"
" exception-name: blah ..."

567
gdb/guile/guile-internal.h Normal file
View File

@ -0,0 +1,567 @@
/* Internal header for GDB/Scheme code.
Copyright (C) 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. */
#ifndef GDB_GUILE_INTERNAL_H
#define GDB_GUILE_INTERNAL_H
#include "hashtab.h"
#include "extension-priv.h"
#include "symtab.h"
#include "libguile.h"
struct block;
struct frame_info;
struct objfile;
struct symbol;
/* A function to pass to the safe-call routines to ignore things like
memory errors. */
typedef int excp_matcher_func (SCM key);
/* Scheme variables to define during initialization. */
typedef struct
{
const char *name;
SCM value;
const char *doc_string;
} scheme_variable;
/* End of scheme_variable table mark. */
#define END_VARIABLES { NULL, SCM_BOOL_F, NULL }
/* Scheme functions to define during initialization. */
typedef struct
{
const char *name;
int required;
int optional;
int rest;
scm_t_subr func;
const char *doc_string;
} scheme_function;
/* End of scheme_function table mark. */
#define END_FUNCTIONS { NULL, 0, 0, 0, NULL, NULL }
/* Useful for defining a set of constants. */
typedef struct
{
const char *name;
int value;
} scheme_integer_constant;
#define END_INTEGER_CONSTANTS { NULL, 0 }
/* Pass this instead of 0 to routines like SCM_ASSERT to indicate the value
is not a function argument. */
#define GDBSCM_ARG_NONE 0
/* Ensure new code doesn't accidentally try to use this. */
#undef scm_make_smob_type
#define scm_make_smob_type USE_gdbscm_make_smob_type_INSTEAD
/* They brought over () == #f from lisp.
Let's avoid that for now. */
#undef scm_is_bool
#undef scm_is_false
#undef scm_is_true
#define scm_is_bool USE_gdbscm_is_bool_INSTEAD
#define scm_is_false USE_gdbscm_is_false_INSTEAD
#define scm_is_true USE_gdbscm_is_true_INSTEAD
#define gdbscm_is_bool(scm) \
(scm_is_eq ((scm), SCM_BOOL_F) || scm_is_eq ((scm), SCM_BOOL_T))
#define gdbscm_is_false(scm) scm_is_eq ((scm), SCM_BOOL_F)
#define gdbscm_is_true(scm) (!gdbscm_is_false (scm))
/* Function name that is passed around in case an error needs to be reported.
__func is in C99, but we provide a wrapper "just in case",
and because FUNC_NAME is the canonical value used in guile sources.
IWBN to use the Scheme version of the name (e.g. foo-bar vs foo_bar),
but let's KISS for now. */
#define FUNC_NAME __func__
extern const char gdbscm_module_name[];
extern const char gdbscm_init_module_name[];
extern int gdb_scheme_initialized;
extern const char gdbscm_print_excp_none[];
extern const char gdbscm_print_excp_full[];
extern const char gdbscm_print_excp_message[];
extern const char *gdbscm_print_excp;
extern SCM gdbscm_documentation_symbol;
extern SCM gdbscm_invalid_object_error_symbol;
extern SCM gdbscm_map_string;
extern SCM gdbscm_array_string;
extern SCM gdbscm_string_string;
/* scm-utils.c */
extern void gdbscm_define_variables (const scheme_variable *, int public);
extern void gdbscm_define_functions (const scheme_function *, int public);
extern void gdbscm_define_integer_constants (const scheme_integer_constant *,
int public);
extern void gdbscm_printf (SCM port, const char *format, ...);
extern void gdbscm_debug_display (SCM obj);
extern void gdbscm_debug_write (SCM obj);
extern void gdbscm_parse_function_args (const char *function_name,
int beginning_arg_pos,
const SCM *keywords,
const char *format, ...);
extern SCM gdbscm_scm_from_longest (LONGEST l);
extern LONGEST gdbscm_scm_to_longest (SCM l);
extern SCM gdbscm_scm_from_ulongest (ULONGEST l);
extern ULONGEST gdbscm_scm_to_ulongest (SCM u);
extern void gdbscm_dynwind_xfree (void *ptr);
extern int gdbscm_is_procedure (SCM proc);
/* GDB smobs, from scm-smob.c */
/* All gdb smobs must contain one of the following as the first member:
gdb_smob, chained_gdb_smob, or eqable_gdb_smob.
The next,prev members of chained_gdb_smob allow for chaining gsmobs
together so that, for example, when an objfile is deleted we can clean up
all smobs that reference it.
The containing_scm member of eqable_gdb_smob allows for returning the
same gsmob instead of creating a new one, allowing them to be eq?-able.
IMPORTANT: chained_gdb_smob and eqable_gdb-smob are a "subclasses" of
gdb_smob. The layout of chained_gdb_smob,eqable_gdb_smob must match
gdb_smob as if it is a subclass. To that end we use macro GDB_SMOB_HEAD
to ensure this. */
#define GDB_SMOB_HEAD \
/* Property list for externally added fields. */ \
SCM properties;
typedef struct
{
GDB_SMOB_HEAD
} gdb_smob;
typedef struct _chained_gdb_smob
{
GDB_SMOB_HEAD
struct _chained_gdb_smob *prev;
struct _chained_gdb_smob *next;
} chained_gdb_smob;
typedef struct _eqable_gdb_smob
{
GDB_SMOB_HEAD
/* The object we are contained in.
This can be used for several purposes.
This is used by the eq? machinery: We need to be able to see if we have
already created an object for a symbol, and if so use that SCM.
This may also be used to protect the smob from GC if there is
a reference to this smob from outside of GC space (i.e., from gdb).
This can also be used in place of chained_gdb_smob where we need to
keep track of objfile referencing objects. When the objfile is deleted
we need to invalidate the objects: we can do that using the same hashtab
used to record the smob for eq-ability. */
SCM containing_scm;
} eqable_gdb_smob;
#undef GDB_SMOB_HEAD
struct objfile;
struct objfile_data;
/* A predicate that returns non-zero if an object is a particular kind
of gsmob. */
typedef int (gsmob_pred_func) (SCM);
extern scm_t_bits gdbscm_make_smob_type (const char *name, size_t size);
extern void gdbscm_init_gsmob (gdb_smob *base);
extern void gdbscm_init_chained_gsmob (chained_gdb_smob *base);
extern void gdbscm_init_eqable_gsmob (eqable_gdb_smob *base);
extern SCM gdbscm_mark_gsmob (gdb_smob *base);
extern SCM gdbscm_mark_chained_gsmob (chained_gdb_smob *base);
extern SCM gdbscm_mark_eqable_gsmob (eqable_gdb_smob *base);
extern void gdbscm_add_objfile_ref (struct objfile *objfile,
const struct objfile_data *data_key,
chained_gdb_smob *g_smob);
extern void gdbscm_remove_objfile_ref (struct objfile *objfile,
const struct objfile_data *data_key,
chained_gdb_smob *g_smob);
extern htab_t gdbscm_create_eqable_gsmob_ptr_map (htab_hash hash_fn,
htab_eq eq_fn);
extern eqable_gdb_smob **gdbscm_find_eqable_gsmob_ptr_slot
(htab_t htab, eqable_gdb_smob *base);
extern void gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot,
eqable_gdb_smob *base,
SCM containing_scm);
extern void gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab,
eqable_gdb_smob *base);
/* Exceptions and calling out to Guile. */
/* scm-exception.c */
extern SCM gdbscm_make_exception (SCM tag, SCM args);
extern int gdbscm_is_exception (SCM scm);
extern SCM gdbscm_exception_key (SCM excp);
extern SCM gdbscm_exception_args (SCM excp);
extern SCM gdbscm_make_exception_with_stack (SCM key, SCM args, SCM stack);
extern SCM gdbscm_make_error_scm (SCM key, SCM subr, SCM message,
SCM args, SCM data);
extern SCM gdbscm_make_error (SCM key, const char *subr, const char *message,
SCM args, SCM data);
extern SCM gdbscm_make_type_error (const char *subr, int arg_pos,
SCM bad_value, const char *expected_type);
extern SCM gdbscm_make_invalid_object_error (const char *subr, int arg_pos,
SCM bad_value, const char *error);
extern SCM gdbscm_invalid_object_error (const char *subr, int arg_pos,
SCM bad_value, const char *error)
ATTRIBUTE_NORETURN;
extern SCM gdbscm_make_out_of_range_error (const char *subr, int arg_pos,
SCM bad_value, const char *error);
extern SCM gdbscm_out_of_range_error (const char *subr, int arg_pos,
SCM bad_value, const char *error)
ATTRIBUTE_NORETURN;
extern SCM gdbscm_make_misc_error (const char *subr, int arg_pos,
SCM bad_value, const char *error);
extern void gdbscm_throw (SCM exception) ATTRIBUTE_NORETURN;
extern SCM gdbscm_scm_from_gdb_exception (struct gdb_exception exception);
extern void gdbscm_throw_gdb_exception (struct gdb_exception exception)
ATTRIBUTE_NORETURN;
extern void gdbscm_print_exception_with_stack (SCM port, SCM stack,
SCM key, SCM args);
extern void gdbscm_print_gdb_exception (SCM port, SCM exception);
extern char *gdbscm_exception_message_to_string (SCM exception);
extern excp_matcher_func gdbscm_memory_error_p;
extern SCM gdbscm_make_memory_error (const char *subr, const char *msg,
SCM args);
extern SCM gdbscm_memory_error (const char *subr, const char *msg, SCM args);
/* scm-safe-call.c */
extern void *gdbscm_with_guile (void *(*func) (void *), void *data);
extern SCM gdbscm_call_guile (SCM (*func) (void *), void *data,
excp_matcher_func *ok_excps);
extern SCM gdbscm_safe_call_0 (SCM proc, excp_matcher_func *ok_excps);
extern SCM gdbscm_safe_call_1 (SCM proc, SCM arg0,
excp_matcher_func *ok_excps);
extern SCM gdbscm_safe_call_2 (SCM proc, SCM arg0, SCM arg1,
excp_matcher_func *ok_excps);
extern SCM gdbscm_safe_call_3 (SCM proc, SCM arg0, SCM arg1, SCM arg2,
excp_matcher_func *ok_excps);
extern SCM gdbscm_safe_call_4 (SCM proc, SCM arg0, SCM arg1, SCM arg2,
SCM arg3,
excp_matcher_func *ok_excps);
extern SCM gdbscm_safe_apply_1 (SCM proc, SCM arg0, SCM args,
excp_matcher_func *ok_excps);
extern SCM gdbscm_unsafe_call_1 (SCM proc, SCM arg0);
extern char *gdbscm_safe_eval_string (const char *string, int display_result);
extern char *gdbscm_safe_source_script (const char *filename);
extern void gdbscm_enter_repl (void);
/* Interface to various GDB objects, in alphabetical order. */
/* scm-arch.c */
typedef struct _arch_smob arch_smob;
extern struct gdbarch *arscm_get_gdbarch (arch_smob *a_smob);
extern arch_smob *arscm_get_arch_smob_arg_unsafe (SCM arch_scm, int arg_pos,
const char *func_name);
extern SCM arscm_scm_from_arch (struct gdbarch *gdbarch);
/* scm-block.c */
extern SCM bkscm_scm_from_block (const struct block *block,
struct objfile *objfile);
extern const struct block *bkscm_scm_to_block
(SCM block_scm, int arg_pos, const char *func_name, SCM *excp);
/* scm-frame.c */
typedef struct _frame_smob frame_smob;
extern int frscm_is_frame (SCM scm);
extern frame_smob *frscm_get_frame_smob_arg_unsafe (SCM frame_scm, int arg_pos,
const char *func_name);
extern struct frame_info *frscm_frame_smob_to_frame (frame_smob *);
/* scm-iterator.c */
typedef struct _iterator_smob iterator_smob;
extern SCM itscm_iterator_smob_object (iterator_smob *i_smob);
extern SCM itscm_iterator_smob_progress (iterator_smob *i_smob);
extern void itscm_set_iterator_smob_progress_x (iterator_smob *i_smob,
SCM progress);
extern const char *itscm_iterator_smob_name (void);
extern SCM gdbscm_make_iterator (SCM object, SCM progress, SCM next);
extern int itscm_is_iterator (SCM scm);
extern SCM gdbscm_end_of_iteration (void);
extern int itscm_is_end_of_iteration (SCM obj);
extern SCM itscm_safe_call_next_x (SCM iter, excp_matcher_func *ok_excps);
extern SCM itscm_get_iterator_arg_unsafe (SCM self, int arg_pos,
const char *func_name);
/* scm-lazy-string.c */
extern int lsscm_is_lazy_string (SCM scm);
extern SCM lsscm_make_lazy_string (CORE_ADDR address, int length,
const char *encoding, struct type *type);
extern struct value *lsscm_safe_lazy_string_to_value (SCM string,
int arg_pos,
const char *func_name,
SCM *except_scmp);
extern void lsscm_val_print_lazy_string
(SCM string, struct ui_file *stream,
const struct value_print_options *options);
/* scm-objfile.c */
typedef struct _objfile_smob objfile_smob;
extern SCM ofscm_objfile_smob_pretty_printers (objfile_smob *o_smob);
extern objfile_smob *ofscm_objfile_smob_from_objfile (struct objfile *objfile);
extern SCM ofscm_scm_from_objfile (struct objfile *objfile);
/* scm-string.c */
extern char *gdbscm_scm_to_c_string (SCM string);
extern SCM gdbscm_scm_from_c_string (const char *string);
extern SCM gdbscm_scm_from_printf (const char *format, ...);
extern char *gdbscm_scm_to_string (SCM string, size_t *lenp,
const char *charset,
int strict, SCM *except_scmp);
extern SCM gdbscm_scm_from_string (const char *string, size_t len,
const char *charset, int strict);
extern char *gdbscm_scm_to_target_string_unsafe (SCM string, size_t *lenp,
struct gdbarch *gdbarch);
/* scm-symbol.c */
extern int syscm_is_symbol (SCM scm);
extern SCM syscm_scm_from_symbol (struct symbol *symbol);
extern struct symbol *syscm_get_valid_symbol_arg_unsafe
(SCM self, int arg_pos, const char *func_name);
/* scm-symtab.c */
extern SCM stscm_scm_from_symtab (struct symtab *symtab);
extern SCM stscm_scm_from_sal (struct symtab_and_line sal);
/* scm-type.c */
typedef struct _type_smob type_smob;
extern int tyscm_is_type (SCM scm);
extern SCM tyscm_scm_from_type (struct type *type);
extern type_smob *tyscm_get_type_smob_arg_unsafe (SCM type_scm, int arg_pos,
const char *func_name);
extern struct type *tyscm_type_smob_type (type_smob *t_smob);
extern SCM tyscm_scm_from_field (SCM type_scm, int field_num);
/* scm-value.c */
extern struct value *vlscm_scm_to_value (SCM scm);
extern int vlscm_is_value (SCM scm);
extern SCM vlscm_scm_from_value (struct value *value);
extern SCM vlscm_scm_from_value_unsafe (struct value *value);
extern struct value *vlscm_convert_typed_value_from_scheme
(const char *func_name, int obj_arg_pos, SCM obj,
int type_arg_pos, SCM type_scm, struct type *type, SCM *except_scmp,
struct gdbarch *gdbarch, const struct language_defn *language);
extern struct value *vlscm_convert_value_from_scheme
(const char *func_name, int obj_arg_pos, SCM obj, SCM *except_scmp,
struct gdbarch *gdbarch, const struct language_defn *language);
/* stript_lang methods */
extern objfile_script_sourcer_func gdbscm_source_objfile_script;
extern int gdbscm_auto_load_enabled (const struct extension_language_defn *);
extern void gdbscm_preserve_values
(const struct extension_language_defn *,
struct objfile *, htab_t copied_types);
extern enum ext_lang_rc gdbscm_apply_val_pretty_printer
(const struct extension_language_defn *,
struct type *type, const gdb_byte *valaddr,
int embedded_offset, CORE_ADDR address,
struct ui_file *stream, int recurse,
const struct value *val,
const struct value_print_options *options,
const struct language_defn *language);
extern int gdbscm_breakpoint_has_cond (const struct extension_language_defn *,
struct breakpoint *b);
extern enum ext_lang_bp_stop gdbscm_breakpoint_cond_says_stop
(const struct extension_language_defn *, struct breakpoint *b);
/* Initializers for each piece of Scheme support, in alphabetical order. */
extern void gdbscm_initialize_arches (void);
extern void gdbscm_initialize_auto_load (void);
extern void gdbscm_initialize_blocks (void);
extern void gdbscm_initialize_breakpoints (void);
extern void gdbscm_initialize_disasm (void);
extern void gdbscm_initialize_exceptions (void);
extern void gdbscm_initialize_frames (void);
extern void gdbscm_initialize_iterators (void);
extern void gdbscm_initialize_lazy_strings (void);
extern void gdbscm_initialize_math (void);
extern void gdbscm_initialize_objfiles (void);
extern void gdbscm_initialize_pretty_printers (void);
extern void gdbscm_initialize_ports (void);
extern void gdbscm_initialize_smobs (void);
extern void gdbscm_initialize_strings (void);
extern void gdbscm_initialize_symbols (void);
extern void gdbscm_initialize_symtabs (void);
extern void gdbscm_initialize_types (void);
extern void gdbscm_initialize_values (void);
/* Use these after a TRY_CATCH to throw the appropriate Scheme exception
if a GDB error occurred. */
#define GDBSCM_HANDLE_GDB_EXCEPTION(exception) \
do { \
if (exception.reason < 0) \
{ \
gdbscm_throw_gdb_exception (exception); \
/*NOTREACHED */ \
} \
} while (0)
/* If cleanups are establish outside the TRY_CATCH block, use this version. */
#define GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS(exception, cleanups) \
do { \
if (exception.reason < 0) \
{ \
do_cleanups (cleanups); \
gdbscm_throw_gdb_exception (exception); \
/*NOTREACHED */ \
} \
} while (0)
#endif /* GDB_GUILE_INTERNAL_H */

724
gdb/guile/guile.c Normal file
View File

@ -0,0 +1,724 @@
/* General GDB/Guile code.
Copyright (C) 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 <string.h>
#include "breakpoint.h"
#include "cli/cli-cmds.h"
#include "cli/cli-script.h"
#include "cli/cli-utils.h"
#include "command.h"
#include "gdbcmd.h"
#include "interps.h"
#include "extension-priv.h"
#include "utils.h"
#include "version.h"
#ifdef HAVE_GUILE
#include "guile.h"
#include "guile-internal.h"
#endif
/* Declared constants and enum for guile exception printing. */
const char gdbscm_print_excp_none[] = "none";
const char gdbscm_print_excp_full[] = "full";
const char gdbscm_print_excp_message[] = "message";
/* "set guile print-stack" choices. */
static const char *const guile_print_excp_enums[] =
{
gdbscm_print_excp_none,
gdbscm_print_excp_full,
gdbscm_print_excp_message,
NULL
};
/* The exception printing variable. 'full' if we want to print the
error message and stack, 'none' if we want to print nothing, and
'message' if we only want to print the error message. 'message' is
the default. */
const char *gdbscm_print_excp = gdbscm_print_excp_message;
#ifdef HAVE_GUILE
/* Forward decls, these are defined later. */
static const struct extension_language_script_ops guile_extension_script_ops;
static const struct extension_language_ops guile_extension_ops;
#endif
/* The main struct describing GDB's interface to the Guile
extension language. */
const struct extension_language_defn extension_language_guile =
{
EXT_LANG_GUILE,
"guile",
"Guile",
".scm",
"-gdb.scm",
guile_control,
#ifdef HAVE_GUILE
&guile_extension_script_ops,
&guile_extension_ops
#else
NULL,
NULL
#endif
};
#ifdef HAVE_GUILE
static void gdbscm_finish_initialization
(const struct extension_language_defn *);
static int gdbscm_initialized (const struct extension_language_defn *);
static void gdbscm_eval_from_control_command
(const struct extension_language_defn *, struct command_line *);
static script_sourcer_func gdbscm_source_script;
int gdb_scheme_initialized;
/* Symbol for setting documentation strings. */
SCM gdbscm_documentation_symbol;
/* Keywords used by various functions. */
static SCM from_tty_keyword;
static SCM to_string_keyword;
/* The name of the various modules (without the surrounding parens). */
const char gdbscm_module_name[] = "gdb";
const char gdbscm_init_module_name[] = "gdb init";
/* The name of the bootstrap file. */
static const char boot_scm_filename[] = "boot.scm";
/* The interface between gdb proper and loading of python scripts. */
static const struct extension_language_script_ops guile_extension_script_ops =
{
gdbscm_source_script,
gdbscm_source_objfile_script,
gdbscm_auto_load_enabled
};
/* The interface between gdb proper and guile scripting. */
static const struct extension_language_ops guile_extension_ops =
{
gdbscm_finish_initialization,
gdbscm_initialized,
gdbscm_eval_from_control_command,
NULL, /* gdbscm_start_type_printers, */
NULL, /* gdbscm_apply_type_printers, */
NULL, /* gdbscm_free_type_printers, */
gdbscm_apply_val_pretty_printer,
NULL, /* gdbscm_apply_frame_filter, */
gdbscm_preserve_values,
gdbscm_breakpoint_has_cond,
gdbscm_breakpoint_cond_says_stop,
NULL, /* gdbscm_check_quit_flag, */
NULL, /* gdbscm_clear_quit_flag, */
NULL, /* gdbscm_set_quit_flag, */
};
/* Implementation of the gdb "guile-repl" command. */
static void
guile_repl_command (char *arg, int from_tty)
{
struct cleanup *cleanup;
cleanup = make_cleanup_restore_integer (&interpreter_async);
interpreter_async = 0;
arg = skip_spaces (arg);
/* This explicitly rejects any arguments for now.
"It is easier to relax a restriction than impose one after the fact."
We would *like* to be able to pass arguments to the interactive shell
but that's not what python-interactive does. Until there is time to
sort it out, we forbid arguments. */
if (arg && *arg)
error (_("guile-repl currently does not take any arguments."));
else
{
dont_repeat ();
gdbscm_enter_repl ();
}
do_cleanups (cleanup);
}
/* Implementation of the gdb "guile" command.
Note: Contrary to the Python version this displays the result.
Have to see which is better.
TODO: Add the result to Guile's history? */
static void
guile_command (char *arg, int from_tty)
{
struct cleanup *cleanup;
cleanup = make_cleanup_restore_integer (&interpreter_async);
interpreter_async = 0;
arg = skip_spaces (arg);
if (arg && *arg)
{
char *msg = gdbscm_safe_eval_string (arg, 1);
if (msg != NULL)
{
make_cleanup (xfree, msg);
error ("%s", msg);
}
}
else
{
struct command_line *l = get_command_line (guile_control, "");
make_cleanup_free_command_lines (&l);
execute_control_command_untraced (l);
}
do_cleanups (cleanup);
}
/* Given a command_line, return a command string suitable for passing
to Guile. Lines in the string are separated by newlines. The return
value is allocated using xmalloc and the caller is responsible for
freeing it. */
static char *
compute_scheme_string (struct command_line *l)
{
struct command_line *iter;
char *script = NULL;
int size = 0;
int here;
for (iter = l; iter; iter = iter->next)
size += strlen (iter->line) + 1;
script = xmalloc (size + 1);
here = 0;
for (iter = l; iter; iter = iter->next)
{
int len = strlen (iter->line);
strcpy (&script[here], iter->line);
here += len;
script[here++] = '\n';
}
script[here] = '\0';
return script;
}
/* Take a command line structure representing a "guile" command, and
evaluate its body using the Guile interpreter.
This is the extension_language_ops.eval_from_control_command "method". */
static void
gdbscm_eval_from_control_command
(const struct extension_language_defn *extlang, struct command_line *cmd)
{
char *script, *msg;
struct cleanup *cleanup;
if (cmd->body_count != 1)
error (_("Invalid \"guile\" block structure."));
cleanup = make_cleanup (null_cleanup, NULL);
script = compute_scheme_string (cmd->body_list[0]);
msg = gdbscm_safe_eval_string (script, 0);
xfree (script);
if (msg != NULL)
{
make_cleanup (xfree, msg);
error ("%s", msg);
}
do_cleanups (cleanup);
}
/* Read a file as Scheme code.
This is the extension_language_script_ops.script_sourcer "method".
FILE is the file to run. FILENAME is name of the file FILE.
This does not throw any errors. If an exception occurs an error message
is printed. */
static void
gdbscm_source_script (const struct extension_language_defn *extlang,
FILE *file, const char *filename)
{
char *msg = gdbscm_safe_source_script (filename);
if (msg != NULL)
{
fprintf_filtered (gdb_stderr, "%s\n", msg);
xfree (msg);
}
}
/* (execute string [#:from-tty boolean] [#:to-string boolean\
A Scheme function which evaluates a string using the gdb CLI. */
static SCM
gdbscm_execute_gdb_command (SCM command_scm, SCM rest)
{
int from_tty_arg_pos = -1, to_string_arg_pos = -1;
int from_tty = 0, to_string = 0;
volatile struct gdb_exception except;
const SCM keywords[] = { from_tty_keyword, to_string_keyword, SCM_BOOL_F };
char *command;
char *result = NULL;
struct cleanup *cleanups;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#tt",
command_scm, &command, rest,
&from_tty_arg_pos, &from_tty,
&to_string_arg_pos, &to_string);
/* Note: The contents of "command" may get modified while it is
executed. */
cleanups = make_cleanup (xfree, command);
TRY_CATCH (except, RETURN_MASK_ALL)
{
struct cleanup *inner_cleanups;
inner_cleanups = make_cleanup_restore_integer (&interpreter_async);
interpreter_async = 0;
prevent_dont_repeat ();
if (to_string)
result = execute_command_to_string (command, from_tty);
else
{
execute_command (command, from_tty);
result = NULL;
}
/* Do any commands attached to breakpoint we stopped at. */
bpstat_do_actions ();
do_cleanups (inner_cleanups);
}
do_cleanups (cleanups);
GDBSCM_HANDLE_GDB_EXCEPTION (except);
if (result)
{
SCM r = gdbscm_scm_from_c_string (result);
xfree (result);
return r;
}
return SCM_UNSPECIFIED;
}
/* (data-directory) -> string */
static SCM
gdbscm_data_directory (void)
{
return gdbscm_scm_from_c_string (gdb_datadir);
}
/* (gdb-version) -> string */
static SCM
gdbscm_gdb_version (void)
{
return gdbscm_scm_from_c_string (version);
}
/* (host-config) -> string */
static SCM
gdbscm_host_config (void)
{
return gdbscm_scm_from_c_string (host_name);
}
/* (target-config) -> string */
static SCM
gdbscm_target_config (void)
{
return gdbscm_scm_from_c_string (target_name);
}
#else /* ! HAVE_GUILE */
/* Dummy implementation of the gdb "guile-repl" and "guile"
commands. */
static void
guile_repl_command (char *arg, int from_tty)
{
arg = skip_spaces (arg);
if (arg && *arg)
error (_("guile-repl currently does not take any arguments."));
error (_("Guile scripting is not supported in this copy of GDB."));
}
static void
guile_command (char *arg, int from_tty)
{
arg = skip_spaces (arg);
if (arg && *arg)
error (_("Guile scripting is not supported in this copy of GDB."));
else
{
/* Even if Guile isn't enabled, we still have to slurp the
command list to the corresponding "end". */
struct command_line *l = get_command_line (guile_control, "");
struct cleanup *cleanups = make_cleanup_free_command_lines (&l);
execute_control_command_untraced (l);
do_cleanups (cleanups);
}
}
#endif /* ! HAVE_GUILE */
/* Lists for 'set,show,info guile' commands. */
static struct cmd_list_element *set_guile_list;
static struct cmd_list_element *show_guile_list;
static struct cmd_list_element *info_guile_list;
/* Function for use by 'set guile' prefix command. */
static void
set_guile_command (char *args, int from_tty)
{
help_list (set_guile_list, "set guile ", all_commands, gdb_stdout);
}
/* Function for use by 'show guile' prefix command. */
static void
show_guile_command (char *args, int from_tty)
{
cmd_show_list (show_guile_list, from_tty, "");
}
/* The "info scheme" command is defined as a prefix, with
allow_unknown 0. Therefore, its own definition is called only for
"info scheme" with no args. */
static void
info_guile_command (char *args, int from_tty)
{
printf_unfiltered (_("\"info guile\" must be followed"
" by the name of an info command.\n"));
help_list (info_guile_list, "info guile ", -1, gdb_stdout);
}
/* Initialization. */
#ifdef HAVE_GUILE
static const scheme_function misc_guile_functions[] =
{
{ "execute", 1, 0, 1, gdbscm_execute_gdb_command,
"\
Execute the given GDB command.\n\
\n\
Arguments: string [#:to-string boolean] [#:from-tty boolean]\n\
If #:from-tty is true then the command executes as if entered\n\
from the keyboard. The default is false (#f).\n\
If #:to-string is true then the result is returned as a string.\n\
Otherwise output is sent to the current output port,\n\
which is the default.\n\
Returns: The result of the command if #:to-string is true.\n\
Otherwise returns unspecified." },
{ "data-directory", 0, 0, 0, gdbscm_data_directory,
"\
Return the name of GDB's data directory." },
{ "gdb-version", 0, 0, 0, gdbscm_gdb_version,
"\
Return GDB's version string." },
{ "host-config", 0, 0, 0, gdbscm_host_config,
"\
Return the name of the host configuration." },
{ "target-config", 0, 0, 0, gdbscm_target_config,
"\
Return the name of the target configuration." },
END_FUNCTIONS
};
/* Load gdb/boot.scm, the Scheme side of GDB/Guile support.
Note: This function assumes it's called within the gdb module. */
static void
initialize_scheme_side (void)
{
char *gdb_guile_dir = concat (gdb_datadir, SLASH_STRING, "guile", NULL);
char *boot_scm_path = concat (gdb_guile_dir, SLASH_STRING, "gdb",
SLASH_STRING, boot_scm_filename, NULL);
char *msg;
/* While scm_c_primitive_load works, the loaded code is not compiled,
instead it is left to be interpreted. Eh?
Anyways, this causes a ~100x slowdown, so we only use it to load
gdb/boot.scm, and then let boot.scm do the rest. */
msg = gdbscm_safe_source_script (boot_scm_path);
if (msg != NULL)
{
fprintf_filtered (gdb_stderr, "%s", msg);
xfree (msg);
warning (_("\n"
"Could not complete Guile gdb module initialization from:\n"
"%s.\n"
"Limited Guile support is available.\n"
"Suggest passing --data-directory=/path/to/gdb/data-directory.\n"),
boot_scm_path);
}
xfree (gdb_guile_dir);
xfree (boot_scm_path);
}
/* Install the gdb scheme module.
The result is a boolean indicating success.
If initializing the gdb module fails an error message is printed.
Note: This function runs in the context of the gdb module. */
static void
initialize_gdb_module (void *data)
{
/* The documentation symbol needs to be defined before any calls to
gdbscm_define_{variables,functions}. */
gdbscm_documentation_symbol = scm_from_latin1_symbol ("documentation");
/* The smob and exception support must be initialized early. */
gdbscm_initialize_smobs ();
gdbscm_initialize_exceptions ();
/* The rest are initialized in alphabetical order. */
gdbscm_initialize_arches ();
gdbscm_initialize_auto_load ();
gdbscm_initialize_blocks ();
gdbscm_initialize_breakpoints ();
gdbscm_initialize_disasm ();
gdbscm_initialize_frames ();
gdbscm_initialize_iterators ();
gdbscm_initialize_lazy_strings ();
gdbscm_initialize_math ();
gdbscm_initialize_objfiles ();
gdbscm_initialize_ports ();
gdbscm_initialize_pretty_printers ();
gdbscm_initialize_strings ();
gdbscm_initialize_symbols ();
gdbscm_initialize_symtabs ();
gdbscm_initialize_types ();
gdbscm_initialize_values ();
gdbscm_define_functions (misc_guile_functions, 1);
from_tty_keyword = scm_from_latin1_keyword ("from-tty");
to_string_keyword = scm_from_latin1_keyword ("to-string");
initialize_scheme_side ();
gdb_scheme_initialized = 1;
}
/* A callback to finish Guile initialization after gdb has finished all its
initialization.
This is the extension_language_ops.finish_initialization "method". */
static void
gdbscm_finish_initialization (const struct extension_language_defn *extlang)
{
/* Restore the environment to the user interaction one. */
scm_set_current_module (scm_interaction_environment ());
}
/* The extension_language_ops.initialized "method". */
static int
gdbscm_initialized (const struct extension_language_defn *extlang)
{
return gdb_scheme_initialized;
}
/* Enable or disable Guile backtraces. */
static void
gdbscm_set_backtrace (int enable)
{
static const char disable_bt[] = "(debug-disable 'backtrace)";
static const char enable_bt[] = "(debug-enable 'backtrace)";
if (enable)
gdbscm_safe_eval_string (enable_bt, 0);
else
gdbscm_safe_eval_string (disable_bt, 0);
}
#endif /* HAVE_GUILE */
/* Install the various gdb commands used by Guile. */
static void
install_gdb_commands (void)
{
add_com ("guile-repl", class_obscure,
guile_repl_command,
#ifdef HAVE_GUILE
_("\
Start an interactive Guile prompt.\n\
\n\
To return to GDB, type the EOF character (e.g., Ctrl-D on an empty\n\
prompt) or ,quit.")
#else /* HAVE_GUILE */
_("\
Start a Guile interactive prompt.\n\
\n\
Guile scripting is not supported in this copy of GDB.\n\
This command is only a placeholder.")
#endif /* HAVE_GUILE */
);
add_com_alias ("gr", "guile-repl", class_obscure, 1);
/* Since "help guile" is easy to type, and intuitive, we add general help
in using GDB+Guile to this command. */
add_com ("guile", class_obscure, guile_command,
#ifdef HAVE_GUILE
_("\
Evaluate one or more Guile expressions.\n\
\n\
The expression(s) can be given as an argument, for instance:\n\
\n\
guile (display 23)\n\
\n\
The result of evaluating the last expression is printed.\n\
\n\
If no argument is given, the following lines are read and passed\n\
to Guile for evaluation. Type a line containing \"end\" to indicate\n\
the end of the set of expressions.\n\
\n\
The Guile GDB module must first be imported before it can be used.\n\
Do this with:\n\
(gdb) guile (use-modules (gdb))\n\
or if you want to import the (gdb) module with a prefix, use:\n\
(gdb) guile (use-modules ((gdb) #:renamer (symbol-prefix-proc 'gdb:)))\n\
\n\
The Guile interactive session, started with the \"guile-repl\"\n\
command, provides extensive help and apropos capabilities.\n\
Type \",help\" once in a Guile interactive session.")
#else /* HAVE_GUILE */
_("\
Evaluate a Guile expression.\n\
\n\
Guile scripting is not supported in this copy of GDB.\n\
This command is only a placeholder.")
#endif /* HAVE_GUILE */
);
add_com_alias ("gu", "guile", class_obscure, 1);
add_prefix_cmd ("guile", class_obscure, set_guile_command,
_("Prefix command for Guile preference settings."),
&set_guile_list, "set guile ", 0,
&setlist);
add_alias_cmd ("gu", "guile", class_obscure, 1, &setlist);
add_prefix_cmd ("guile", class_obscure, show_guile_command,
_("Prefix command for Guile preference settings."),
&show_guile_list, "show guile ", 0,
&showlist);
add_alias_cmd ("gu", "guile", class_obscure, 1, &showlist);
add_prefix_cmd ("guile", class_obscure, info_guile_command,
_("Prefix command for Guile info displays."),
&info_guile_list, "info guile ", 0,
&infolist);
add_info_alias ("gu", "guile", 1);
/* The name "print-stack" is carried over from Python.
A better name is "print-exception". */
add_setshow_enum_cmd ("print-stack", no_class, guile_print_excp_enums,
&gdbscm_print_excp, _("\
Set mode for Guile exception printing on error."), _("\
Show the mode of Guile exception printing on error."), _("\
none == no stack or message will be printed.\n\
full == a message and a stack will be printed.\n\
message == an error message without a stack will be printed."),
NULL, NULL,
&set_guile_list, &show_guile_list);
}
/* Provide a prototype to silence -Wmissing-prototypes. */
extern initialize_file_ftype _initialize_guile;
void
_initialize_guile (void)
{
char *msg;
install_gdb_commands ();
#if HAVE_GUILE
/* The Guile docs say scm_init_guile isn't as portable as the other Guile
initialization routines. However, this is the easiest to use.
We can switch to a more portable routine if/when the need arises
and if it can be used with gdb. */
scm_init_guile ();
/* The Python support puts the C side in module "_gdb", leaving the Python
side to define module "gdb" which imports "_gdb". There is evidently no
similar convention in Guile so we skip this. */
/* The rest of the initialization is done by initialize_gdb_module.
scm_c_define_module is used as it allows us to perform the initialization
within the desired module. */
scm_c_define_module (gdbscm_module_name, initialize_gdb_module, NULL);
/* Set Guile's backtrace to match the "set guile print-stack" default.
[N.B. The two settings are still separate.]
But only do this after we've initialized Guile, it's nice to see a
backtrace if there's an error during initialization.
OTOH, if the error is that gdb/init.scm wasn't found because gdb is being
run from the build tree, the backtrace is more noise than signal.
Sigh. */
gdbscm_set_backtrace (0);
#endif
}

28
gdb/guile/guile.h Normal file
View File

@ -0,0 +1,28 @@
/* General GDB/Scheme code.
Copyright (C) 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/>. */
#ifndef GDB_GUILE_H
#define GDB_GUILE_H
#include "extension.h"
/* This is all that guile exports to gdb. */
extern const struct extension_language_defn extension_language_guile;
#endif /* GDB_GUILE_H */

452
gdb/guile/lib/gdb.scm Normal file
View File

@ -0,0 +1,452 @@
;; Scheme side of the gdb module.
;;
;; Copyright (C) 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/>.
;; This file is loaded with scm_c_primitive_load, which is ok, but files
;; loaded with it are not compiled. So we do very little here, and do
;; most of the initialization in init.scm.
(define-module (gdb)
;; The version of the (gdb) module as (major minor).
;; Incompatible changes bump the major version.
;; Other changes bump the minor version.
;; It's not clear whether we need a patch-level as well, but this can
;; be added later if necessary.
;; This is not the GDB version on purpose. This version tracks the Scheme
;; gdb module version.
;; TODO: Change to (1 0) when ready.
#:version (0 1))
;; Export the bits provided by the C side.
;; This is so that the compiler can see the exports when
;; other code uses this module.
;; TODO: Generating this list would be nice, but it would require an addition
;; to the GDB build system. Still, I think it's worth it.
(export
;; guile.c
execute
data-directory
gdb-version
host-config
target-config
;; scm-arch.c
arch?
current-arch
arch-name
arch-charset
arch-wide-charset
arch-void-type
arch-char-type
arch-short-type
arch-int-type
arch-long-type
arch-schar-type
arch-uchar-type
arch-ushort-type
arch-uint-type
arch-ulong-type
arch-float-type
arch-double-type
arch-longdouble-type
arch-bool-type
arch-longlong-type
arch-ulonglong-type
arch-int8-type
arch-uint8-type
arch-int16-type
arch-uint16-type
arch-int32-type
arch-uint32-type
arch-int64-type
arch-uint64-type
;; scm-block.c
block?
block-valid?
block-start
block-end
block-function
block-superblock
block-global-block
block-static-block
block-global?
block-static?
block-symbols
make-block-symbols-iterator
block-symbols-progress?
lookup-block
;; scm-breakpoint.c
BP_NONE
BP_BREAKPOINT
BP_WATCHPOINT
BP_HARDWARE_WATCHPOINT
BP_READ_WATCHPOINT
BP_ACCESS_WATCHPOINT
WP_READ
WP_WRITE
WP_ACCESS
make-breakpoint
breakpoint-delete!
breakpoints
breakpoint?
breakpoint-valid?
breakpoint-number
breakpoint-type
brekapoint-visible?
breakpoint-location
breakpoint-expression
breakpoint-enabled?
set-breakpoint-enabled!
breakpoint-silent?
set-breakpoint-silent!
breakpoint-ignore-count
set-breakpoint-ignore-count!
breakpoint-hit-count
set-breakpoint-hit-count!
breakpoint-thread
set-breakpoint-thread!
breakpoint-task
set-breakpoint-task!
breakpoint-condition
set-breakpoint-condition!
breakpoint-stop
set-breakpoint-stop!
breakpoint-commands
;; scm-disasm.c
arch-disassemble
;; scm-exception.c
make-exception
exception?
exception-key
exception-args
;; scm-frame.c
NORMAL_FRAME
DUMMY_FRAME
INLINE_FRAME
TAILCALL_FRAME
SIGTRAMP_FRAME
ARCH_FRAME
SENTINEL_FRAME
FRAME_UNWIND_NO_REASON
FRAME_UNWIND_NULL_ID
FRAME_UNWIND_OUTERMOST
FRAME_UNWIND_UNAVAILABLE
FRAME_UNWIND_INNER_ID
FRAME_UNWIND_SAME_ID
FRAME_UNWIND_NO_SAVED_PC
frame?
frame-valid?
frame-name
frame-type
frame-arch
frame-unwind-stop-reason
frame-pc
frame-block
frame-function
frame-older
frame-newer
frame-sal
frame-read-var
frame-select
newest-frame
selected-frame
unwind-stop-reason-string
;; scm-iterator.c
make-iterator
iterator?
iterator-object
iterator-progress
set-iterator-progress!
iterator-next!
end-of-iteration
end-of-iteration?
;; scm-lazy-string.c
;; FIXME: Where's the constructor?
lazy-string?
lazy-string-address
lazy-string-length
lazy-string-encoding
lazy-string-type
lazy-string->value
;; scm-math.c
valid-add
value-sub
value-mul
value-div
value-rem
value-mod
value-pow
value-not
value-neg
value-pos
value-abs
value-lsh
value-rsh
value-min
value-max
value-lognot
value-logand
value-logior
value-logxor
value=?
value<?
value<=?
value>?
value>=?
;; scm-objfile.c
objfile?
objfile-valid?
objfile-filename
objfile-pretty-printers
set-objfile-pretty-printers!
current-objfile
objfiles
;; scm-ports.c
input-port
output-port
error-port
stdio-port?
open-memory
memory-port?
memory-port-range
memory-port-read-buffer-size
set-memory-port-read-buffer-size!
memory-port-write-buffer-size
set-memory-port-write-buffer-size!
;; with-gdb-output-to-port, with-gdb-error-to-port are in experimental.scm.
;; scm-pretty-print.c
make-pretty-printer
pretty-printer?
pretty-printer-enabled?
set-pretty-printer-enabled!
make-pretty-printer-worker
pretty-printer-worker?
;; scm-smob.c
gsmob-kind
gsmob-property
set-gsmob-property!
gsmob-has-property?
gsmob-properties
;; scm-string.c
string->argv
;; scm-symbol.c
SYMBOL_LOC_UNDEF
SYMBOL_LOC_CONST
SYMBOL_LOC_STATIC
SYMBOL_LOC_REGISTER
SYMBOL_LOC_ARG
SYMBOL_LOC_REF_ARG
SYMBOL_LOC_LOCAL
SYMBOL_LOC_TYPEDEF
SYMBOL_LOC_LABEL
SYMBOL_LOC_BLOCK
SYMBOL_LOC_CONST_BYTES
SYMBOL_LOC_UNRESOLVED
SYMBOL_LOC_OPTIMIZED_OUT
SYMBOL_LOC_COMPUTED
SYMBOL_LOC_REGPARM_ADDR
SYMBOL_UNDEF_DOMAIN
SYMBOL_VAR_DOMAIN
SYMBOL_STRUCT_DOMAIN
SYMBOL_LABEL_DOMAIN
SYMBOL_VARIABLES_DOMAIN
SYMBOL_FUNCTIONS_DOMAIN
SYMBOL_TYPES_DOMAIN
symbol?
symbol-valid?
symbol-type
symbol-symtab
symbol-line
symbol-name
symbol-linkage-name
symbol-print-name
symbol-addr-class
symbol-argument?
symbol-constant?
symbol-function?
symbol-variable?
symbol-needs-frame?
symbol-value
lookup-symbol
lookup-global-symbol
;; scm-symtab.c
symtab?
symtab-valid?
symtab-filename
symtab-fullname
symtab-objfile
symtab-global-block
symtab-static-block
sal?
sal-valid?
sal-symtab
sal-line
sal-pc
sal-last
find-pc-line
;; scm-type.c
TYPE_CODE_BITSTRING
TYPE_CODE_PTR
TYPE_CODE_ARRAY
TYPE_CODE_STRUCT
TYPE_CODE_UNION
TYPE_CODE_ENUM
TYPE_CODE_FLAGS
TYPE_CODE_FUNC
TYPE_CODE_INT
TYPE_CODE_FLT
TYPE_CODE_VOID
TYPE_CODE_SET
TYPE_CODE_RANGE
TYPE_CODE_STRING
TYPE_CODE_ERROR
TYPE_CODE_METHOD
TYPE_CODE_METHODPTR
TYPE_CODE_MEMBERPTR
TYPE_CODE_REF
TYPE_CODE_CHAR
TYPE_CODE_BOOL
TYPE_CODE_COMPLEX
TYPE_CODE_TYPEDEF
TYPE_CODE_NAMESPACE
TYPE_CODE_DECFLOAT
TYPE_CODE_INTERNAL_FUNCTION
type?
lookup-type
type-code
type-fields
type-tag
type-sizeof
type-strip-typedefs
type-array
type-vector
type-pointer
type-range
type-reference
type-target
type-const
type-volatile
type-unqualified
type-name
type-num-fields
type-fields
make-field-iterator
type-field
type-has-field?
field?
field-name
field-type
field-enumval
field-bitpos
field-bitsize
field-artificial?
field-baseclass?
;; scm-value.c
value?
make-value
value-optimized-out?
value-address
value-type
value-dynamic-type
value-cast
value-dynamic-cast
value-reinterpret-cast
value-dereference
value-referenced-value
value-field
value-subscript
value-call
value->bool
value->integer
value->real
value->bytevector
value->string
value->lazy-string
value-lazy?
make-lazy-value
value-fetch-lazy!
value-print
parse-and-eval
history-ref
)
;; Load the rest of the Scheme side.
;; data-directory is provided by the C code.
(add-to-load-path
(string-append (data-directory) file-name-separator-string "guile"))
(use-modules ((gdb init)))
;; These come from other files, but they're really part of this module.
(re-export
;; init.scm
orig-input-port
orig-output-port
orig-error-port
)

View File

@ -0,0 +1,31 @@
;; Bootstrap the Scheme side of the gdb module.
;;
;; Copyright (C) 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/>.
;; This file is loaded with scm_c_primitive_load, which is ok, but files
;; loaded with it are not compiled. So we do very little here, and do
;; most of the initialization elsewhere.
;; data-directory is provided by the C code.
(load (string-append
(data-directory) file-name-separator-string "guile"
file-name-separator-string "gdb.scm"))
;; Now that the Scheme side support is loaded, initialize it.
(let ((init-proc (@@ (gdb init) %initialize!)))
(init-proc))

View File

@ -0,0 +1,35 @@
;; Various experimental utilities.
;; Anything in this file can change or disappear.
;;
;; Copyright (C) 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/>.
;; TODO: Split this file up by function?
;; E.g., (gdb experimental ports), etc.
(define-module (gdb experimental)
#:use-module (gdb)
#:use-module (gdb init))
;; These are defined in C.
(define-public with-gdb-output-to-port (@@ (gdb) %with-gdb-output-to-port))
(define-public with-gdb-error-to-port (@@ (gdb) %with-gdb-error-to-port))
(define-public (with-gdb-output-to-string thunk)
"Calls THUNK and returns all GDB output as a string."
(call-with-output-string
(lambda (p) (with-gdb-output-to-port p thunk))))

173
gdb/guile/lib/gdb/init.scm Normal file
View File

@ -0,0 +1,173 @@
;; Scheme side of the gdb module.
;;
;; Copyright (C) 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/>.
(define-module (gdb init)
#:use-module (gdb))
(define-public SCM_ARG1 1)
(define-public SCM_ARG2 2)
;; The original i/o ports. In case the user wants them back.
(define %orig-input-port #f)
(define %orig-output-port #f)
(define %orig-error-port #f)
;; %exception-print-style is exported as "private" by gdb.
(define %exception-print-style (@@ (gdb) %exception-print-style))
;; Keys for GDB-generated exceptions.
;; gdb:with-stack is handled separately.
(define %exception-keys '(gdb:error
gdb:invalid-object-error
gdb:memory-error
gdb:pp-type-error))
;; Printer for gdb exceptions, used when Scheme tries to print them directly.
(define (%exception-printer port key args default-printer)
(apply (case-lambda
((subr msg args . rest)
(if subr
(format port "In procedure ~a: " subr))
(apply format port msg (or args '())))
(_ (default-printer)))
args))
;; Print the message part of a gdb:with-stack exception.
;; The arg list is the way it is because it's passed to set-exception-printer!.
;; We don't print a backtrace here because Guile will have already printed a
;; backtrace.
(define (%with-stack-exception-printer port key args default-printer)
(let ((real-key (car args))
(real-args (cddr args)))
(%exception-printer port real-key real-args default-printer)))
;; Copy of Guile's print-exception that tweaks the output for our purposes.
;; TODO: It's not clear the tweaking is still necessary.
(define (%print-exception-message-worker port key args)
(define (default-printer)
(format port "Throw to key `~a' with args `~s'." key args))
(format port "ERROR: ")
;; Pass #t for tag to catch all errors.
(catch #t
(lambda ()
(%exception-printer port key args default-printer))
(lambda (k . args)
(format port "Error while printing gdb exception: ~a ~s."
k args)))
(newline port)
(force-output port))
;; Called from the C code to print an exception.
;; Guile prints them a little differently than we want.
;; See boot-9.scm:print-exception.
(define (%print-exception-message port frame key args)
(cond ((memq key %exception-keys)
(%print-exception-message-worker port key args))
(else
(print-exception port frame key args)))
*unspecified*)
;; Called from the C code to print an exception according to the setting
;; of "guile print-stack".
;;
;; If PORT is #f, use the standard error port.
;; If STACK is #f, never print the stack, regardless of whether printing it
;; is enabled. If STACK is #t, then print it if it is contained in ARGS
;; (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
;; scm_make_stack (which will be ignored in favor of the stack in ARGS if
;; KEY is gdb:with-stack).
;; KEY, ARGS are the standard arguments to scm_throw, et.al.
(define (%print-exception-with-stack port stack key args)
(let ((style (%exception-print-style)))
(if (not (eq? style 'none))
(let ((error-port (current-error-port))
(frame #f))
(if (not port)
(set! port error-port))
(if (eq? port error-port)
(begin
(force-output (current-output-port))
;; In case the current output port is not gdb's output port.
(force-output (output-port))))
;; If the exception is gdb:with-stack, unwrap it to get the stack and
;; underlying exception. If the caller happens to pass in a stack,
;; we ignore it and use the one in ARGS instead.
(if (eq? key 'gdb:with-stack)
(begin
(set! key (car args))
(if stack
(set! stack (cadr args)))
(set! args (cddr args))))
;; If caller wanted a stack and there isn't one, disable backtracing.
(if (eq? stack #t)
(set! stack #f))
;; At this point if stack is true, then it is assumed to be a stack.
(if stack
(set! frame (stack-ref stack 0)))
(if (and (eq? style 'full) stack)
(begin
;; This is derived from libguile/throw.c:handler_message.
;; We include "Guile" in "Guile Backtrace" whereas the Guile
;; version does not so that tests can know it's us printing
;; the backtrace. Plus it could help beginners.
(display "Guile Backtrace:\n" port)
(display-backtrace stack port #f #f '())
(newline port)))
(%print-exception-message port frame key args)))))
;; Internal utility to check the type of an argument, akin to SCM_ASSERT_TYPE.
;; It's public so other gdb modules can use it.
(define-public (%assert-type test-result arg pos func-name)
(if (not test-result)
(scm-error 'wrong-type-arg func-name
"Wrong type argument in position ~a: ~s"
(list pos arg) (list arg))))
;; Internal utility called during startup to initialize the Scheme side of
;; GDB+Guile.
(define (%initialize!)
(add-to-load-path (string-append (data-directory)
file-name-separator-string "guile"))
(for-each (lambda (key)
(set-exception-printer! key %exception-printer))
%exception-keys)
(set-exception-printer! 'gdb:with-stack %with-stack-exception-printer)
(set! %orig-input-port (set-current-input-port (input-port)))
(set! %orig-output-port (set-current-output-port (output-port)))
(set! %orig-error-port (set-current-error-port (error-port))))
;; Public routines.
(define-public (orig-input-port) %orig-input-port)
(define-public (orig-output-port) %orig-output-port)
(define-public (orig-error-port) %orig-error-port)

View File

@ -0,0 +1,80 @@
;; Iteration utilities.
;; Anything in this file can change or disappear.
;;
;; Copyright (C) 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/>.
(define-module (gdb iterator)
#:use-module (gdb))
(define-public (make-list-iterator l)
"Return a <gdb:iterator> object for a list."
(%assert-type (list? l) l SCM_ARG1 'make-list-iterator)
(let ((next! (lambda (iter)
(let ((l (iterator-progress iter)))
(if (eq? l '())
(end-of-iteration)
(begin
(set-iterator-progress! iter (cdr l))
(car l)))))))
(make-iterator l l next!)))
(define-public (iterator->list iter)
"Return the elements of ITER as a list."
(let loop ((iter iter)
(result '()))
(let ((next (iterator-next! iter)))
(if (end-of-iteration? next)
(reverse! result)
(loop iter (cons next result))))))
(define-public (iterator-map proc iter)
"Return a list of PROC applied to each element."
(let loop ((proc proc)
(iter iter)
(result '()))
(let ((next (iterator-next! iter)))
(if (end-of-iteration? next)
(reverse! result)
(loop proc iter (cons (proc next) result))))))
(define-public (iterator-for-each proc iter)
"Apply PROC to each element. The result is unspecified."
(let ((next (iterator-next! iter)))
(if (not (end-of-iteration? next))
(begin
(proc next)
(iterator-for-each proc iter)))))
(define-public (iterator-filter pred iter)
"Return the elements that satify predicate PRED."
(let loop ((result '()))
(let ((next (iterator-next! iter)))
(cond ((end-of-iteration? next) (reverse! result))
((pred next) (loop (cons next result)))
(else (loop result))))))
(define-public (iterator-until pred iter)
"Run the iterator until the result of (pred element) is true.
Returns:
The result of the first (pred element) call that returns true,
or #f if no element matches."
(let loop ((next (iterator-next! iter)))
(cond ((end-of-iteration? next) #f)
((pred next) => identity)
(else (loop (iterator-next! iter))))))

View File

@ -0,0 +1,52 @@
;; Additional pretty-printer support.
;;
;; Copyright (C) 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/>.
(define-module (gdb printing)
#:use-module ((gdb) #:select
(*pretty-printers* pretty-printer? objfile?
objfile-pretty-printers set-objfile-pretty-printers!))
#:use-module (gdb init))
(define-public (prepend-pretty-printer! obj matcher)
"Add MATCHER to the beginning of the pretty-printer list for OBJ.
If OBJ is #f, add MATCHER to the global list."
(%assert-type (pretty-printer? matcher) matcher SCM_ARG1
'prepend-pretty-printer!)
(cond ((eq? obj #f)
(set! *pretty-printers* (cons matcher *pretty-printers*)))
((objfile? obj)
(set-objfile-pretty-printers! obj
(cons matcher
(objfile-pretty-printers obj))))
(else
(%assert-type #f obj SCM_ARG1 'prepend-pretty-printer!))))
(define-public (append-pretty-printer! obj matcher)
"Add MATCHER to the end of the pretty-printer list for OBJ.
If OBJ is #f, add MATCHER to the global list."
(%assert-type (pretty-printer? matcher) matcher SCM_ARG1
'append-pretty-printer!)
(cond ((eq? obj #f)
(set! *pretty-printers* (append! *pretty-printers* (list matcher))))
((objfile? obj)
(set-objfile-pretty-printers! obj
(append! (objfile-pretty-printers obj)
matcher)))
(else
(%assert-type #f obj SCM_ARG1 'append-pretty-printer!))))

View File

@ -0,0 +1,78 @@
;; Type utilities.
;; Copyright (C) 2010-2014 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/>.
(define-module (gdb types)
#:use-module (gdb)
#:use-module (gdb init)
#:use-module (gdb iterator))
(define-public (type-has-field-deep? type field-name)
"Return #t if the type, including baseclasses, has the specified field.
Arguments:
type: The type to examine. It must be a struct or union.
field-name: The name of the field to look up.
Returns:
True if the field is present either in type_ or any baseclass.
Raises:
wrong-type-arg: The type is not a struct or union."
(define (search-class type)
(let ((find-in-baseclass (lambda (field)
(if (field-baseclass? field)
(search-class (field-type field))
;; Not a baseclass, search ends now.
;; Return #:end to end search.
#:end))))
(let ((search-baseclasses
(lambda (type)
(iterator-until find-in-baseclass
(make-field-iterator type)))))
(or (type-has-field? type field-name)
(not (eq? (search-baseclasses type) #:end))))))
(if (= (type-code type) TYPE_CODE_REF)
(set! type (type-target type)))
(set! type (type-strip-typedefs type))
(%assert-type (memq (type-code type) (list TYPE_CODE_STRUCT TYPE_CODE_UNION))
type SCM_ARG1 'type-has-field-deep?)
(search-class type))
(define-public (make-enum-hashtable enum-type)
"Return a hash table from a program's enum type.
Elements in the hash table are fetched with hashq-ref.
Arguments:
enum-type: The enum to compute the hash table for.
Returns:
The hash table of the enum.
Raises:
wrong-type-arg: The type is not an enum."
(%assert-type (= (type-code enum-type) TYPE_CODE_ENUM)
enum-type SCM_ARG1 'make-enum-hashtable)
(let ((htab (make-hash-table)))
(for-each (lambda (enum)
(hash-set! htab (field-name enum) (field-enumval enum)))
(type-fields enum-type))
htab))

668
gdb/guile/scm-arch.c Normal file
View File

@ -0,0 +1,668 @@
/* Scheme interface to architecture.
Copyright (C) 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 "charset.h"
#include "gdbarch.h"
#include "arch-utils.h"
#include "guile-internal.h"
/* The <gdb:arch> smob.
The typedef for this struct is in guile-internal.h. */
struct _arch_smob
{
/* This always appears first. */
gdb_smob base;
struct gdbarch *gdbarch;
};
static const char arch_smob_name[] = "gdb:arch";
/* The tag Guile knows the arch smob by. */
static scm_t_bits arch_smob_tag;
static struct gdbarch_data *arch_object_data = NULL;
static int arscm_is_arch (SCM);
/* Administrivia for arch smobs. */
/* The smob "mark" function for <gdb:arch>. */
static SCM
arscm_mark_arch_smob (SCM self)
{
arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
/* Do this last. */
return gdbscm_mark_gsmob (&a_smob->base);
}
/* The smob "print" function for <gdb:arch>. */
static int
arscm_print_arch_smob (SCM self, SCM port, scm_print_state *pstate)
{
arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
struct gdbarch *gdbarch = a_smob->gdbarch;
gdbscm_printf (port, "#<%s", arch_smob_name);
gdbscm_printf (port, " %s", gdbarch_bfd_arch_info (gdbarch)->printable_name);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* Low level routine to create a <gdb:arch> object for GDBARCH. */
static SCM
arscm_make_arch_smob (struct gdbarch *gdbarch)
{
arch_smob *a_smob = (arch_smob *)
scm_gc_malloc (sizeof (arch_smob), arch_smob_name);
SCM a_scm;
a_smob->gdbarch = gdbarch;
a_scm = scm_new_smob (arch_smob_tag, (scm_t_bits) a_smob);
gdbscm_init_gsmob (&a_smob->base);
return a_scm;
}
/* Return the gdbarch field of A_SMOB. */
struct gdbarch *
arscm_get_gdbarch (arch_smob *a_smob)
{
return a_smob->gdbarch;
}
/* Return non-zero if SCM is an architecture smob. */
static int
arscm_is_arch (SCM scm)
{
return SCM_SMOB_PREDICATE (arch_smob_tag, scm);
}
/* (arch? object) -> boolean */
static SCM
gdbscm_arch_p (SCM scm)
{
return scm_from_bool (arscm_is_arch (scm));
}
/* Associates an arch_object with GDBARCH as gdbarch_data via the gdbarch
post init registration mechanism (gdbarch_data_register_post_init). */
static void *
arscm_object_data_init (struct gdbarch *gdbarch)
{
SCM arch_scm = arscm_make_arch_smob (gdbarch);
/* This object lasts the duration of the GDB session, so there is no
call to scm_gc_unprotect_object for it. */
scm_gc_protect_object (arch_scm);
return (void *) arch_scm;
}
/* Return the <gdb:arch> object corresponding to GDBARCH.
The object is cached in GDBARCH so this is simple. */
SCM
arscm_scm_from_arch (struct gdbarch *gdbarch)
{
SCM a_scm = (SCM) gdbarch_data (gdbarch, arch_object_data);
return a_scm;
}
/* Return the <gdb:arch> smob in SELF.
Throws an exception if SELF is not a <gdb:arch> object. */
static SCM
arscm_get_arch_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (arscm_is_arch (self), self, arg_pos, func_name,
arch_smob_name);
return self;
}
/* Return a pointer to the arch smob of SELF.
Throws an exception if SELF is not a <gdb:arch> object. */
arch_smob *
arscm_get_arch_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM a_scm = arscm_get_arch_arg_unsafe (self, arg_pos, func_name);
arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (a_scm);
return a_smob;
}
/* Arch methods. */
/* (current-arch) -> <gdb:arch>
Return the architecture of the currently selected stack frame,
if there is one, or the current target if there isn't. */
static SCM
gdbscm_current_arch (void)
{
return arscm_scm_from_arch (get_current_arch ());
}
/* (arch-name <gdb:arch>) -> string
Return the name of the architecture as a string value. */
static SCM
gdbscm_arch_name (SCM self)
{
arch_smob *a_smob
= arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct gdbarch *gdbarch = a_smob->gdbarch;
const char *name;
name = (gdbarch_bfd_arch_info (gdbarch))->printable_name;
return gdbscm_scm_from_c_string (name);
}
/* (arch-charset <gdb:arch>) -> string */
static SCM
gdbscm_arch_charset (SCM self)
{
arch_smob *a_smob
=arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct gdbarch *gdbarch = a_smob->gdbarch;
return gdbscm_scm_from_c_string (target_charset (gdbarch));
}
/* (arch-wide-charset <gdb:arch>) -> string */
static SCM
gdbscm_arch_wide_charset (SCM self)
{
arch_smob *a_smob
= arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct gdbarch *gdbarch = a_smob->gdbarch;
return gdbscm_scm_from_c_string (target_wide_charset (gdbarch));
}
/* Builtin types.
The order the types are defined here follows the order in
struct builtin_type. */
/* Helper routine to return a builtin type for <gdb:arch> object SELF.
OFFSET is offsetof (builtin_type, the_type).
Throws an exception if SELF is not a <gdb:arch> object. */
static const struct builtin_type *
gdbscm_arch_builtin_type (SCM self, const char *func_name)
{
arch_smob *a_smob
= arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, func_name);
struct gdbarch *gdbarch = a_smob->gdbarch;
return builtin_type (gdbarch);
}
/* (arch-void-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_void_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_void;
return tyscm_scm_from_type (type);
}
/* (arch-char-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_char_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_char;
return tyscm_scm_from_type (type);
}
/* (arch-short-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_short_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_short;
return tyscm_scm_from_type (type);
}
/* (arch-int-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_int_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int;
return tyscm_scm_from_type (type);
}
/* (arch-long-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_long_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long;
return tyscm_scm_from_type (type);
}
/* (arch-schar-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_schar_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_signed_char;
return tyscm_scm_from_type (type);
}
/* (arch-uchar-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_uchar_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_char;
return tyscm_scm_from_type (type);
}
/* (arch-ushort-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_ushort_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_short;
return tyscm_scm_from_type (type);
}
/* (arch-uint-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_uint_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_int;
return tyscm_scm_from_type (type);
}
/* (arch-ulong-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_ulong_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long;
return tyscm_scm_from_type (type);
}
/* (arch-float-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_float_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_float;
return tyscm_scm_from_type (type);
}
/* (arch-double-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_double_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_double;
return tyscm_scm_from_type (type);
}
/* (arch-longdouble-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_longdouble_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_double;
return tyscm_scm_from_type (type);
}
/* (arch-bool-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_bool_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_bool;
return tyscm_scm_from_type (type);
}
/* (arch-longlong-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_longlong_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_long;
return tyscm_scm_from_type (type);
}
/* (arch-ulonglong-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_ulonglong_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long_long;
return tyscm_scm_from_type (type);
}
/* (arch-int8-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_int8_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int8;
return tyscm_scm_from_type (type);
}
/* (arch-uint8-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_uint8_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint8;
return tyscm_scm_from_type (type);
}
/* (arch-int16-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_int16_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int16;
return tyscm_scm_from_type (type);
}
/* (arch-uint16-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_uint16_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint16;
return tyscm_scm_from_type (type);
}
/* (arch-int32-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_int32_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int32;
return tyscm_scm_from_type (type);
}
/* (arch-uint32-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_uint32_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint32;
return tyscm_scm_from_type (type);
}
/* (arch-int64-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_int64_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int64;
return tyscm_scm_from_type (type);
}
/* (arch-uint64-type <gdb:arch>) -> <gdb:type> */
static SCM
gdbscm_arch_uint64_type (SCM self)
{
struct type *type
= gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint64;
return tyscm_scm_from_type (type);
}
/* Initialize the Scheme architecture support. */
static const scheme_function arch_functions[] =
{
{ "arch?", 1, 0, 0, gdbscm_arch_p,
"\
Return #t if the object is a <gdb:arch> object." },
{ "current-arch", 0, 0, 0, gdbscm_current_arch,
"\
Return the <gdb:arch> object representing the architecture of the\n\
currently selected stack frame, if there is one, or the architecture of the\n\
current target if there isn't.\n\
\n\
Arguments: none" },
{ "arch-name", 1, 0, 0, gdbscm_arch_name,
"\
Return the name of the architecture." },
{ "arch-charset", 1, 0, 0, gdbscm_arch_charset,
"\
Return name of target character set as a string." },
{ "arch-wide-charset", 1, 0, 0, gdbscm_arch_wide_charset,
"\
Return name of target wide character set as a string." },
{ "arch-void-type", 1, 0, 0, gdbscm_arch_void_type,
"\
Return the <gdb:type> object for the \"void\" type\n\
of the architecture." },
{ "arch-char-type", 1, 0, 0, gdbscm_arch_char_type,
"\
Return the <gdb:type> object for the \"char\" type\n\
of the architecture." },
{ "arch-short-type", 1, 0, 0, gdbscm_arch_short_type,
"\
Return the <gdb:type> object for the \"short\" type\n\
of the architecture." },
{ "arch-int-type", 1, 0, 0, gdbscm_arch_int_type,
"\
Return the <gdb:type> object for the \"int\" type\n\
of the architecture." },
{ "arch-long-type", 1, 0, 0, gdbscm_arch_long_type,
"\
Return the <gdb:type> object for the \"long\" type\n\
of the architecture." },
{ "arch-schar-type", 1, 0, 0, gdbscm_arch_schar_type,
"\
Return the <gdb:type> object for the \"signed char\" type\n\
of the architecture." },
{ "arch-uchar-type", 1, 0, 0, gdbscm_arch_uchar_type,
"\
Return the <gdb:type> object for the \"unsigned char\" type\n\
of the architecture." },
{ "arch-ushort-type", 1, 0, 0, gdbscm_arch_ushort_type,
"\
Return the <gdb:type> object for the \"unsigned short\" type\n\
of the architecture." },
{ "arch-uint-type", 1, 0, 0, gdbscm_arch_uint_type,
"\
Return the <gdb:type> object for the \"unsigned int\" type\n\
of the architecture." },
{ "arch-ulong-type", 1, 0, 0, gdbscm_arch_ulong_type,
"\
Return the <gdb:type> object for the \"unsigned long\" type\n\
of the architecture." },
{ "arch-float-type", 1, 0, 0, gdbscm_arch_float_type,
"\
Return the <gdb:type> object for the \"float\" type\n\
of the architecture." },
{ "arch-double-type", 1, 0, 0, gdbscm_arch_double_type,
"\
Return the <gdb:type> object for the \"double\" type\n\
of the architecture." },
{ "arch-longdouble-type", 1, 0, 0, gdbscm_arch_longdouble_type,
"\
Return the <gdb:type> object for the \"long double\" type\n\
of the architecture." },
{ "arch-bool-type", 1, 0, 0, gdbscm_arch_bool_type,
"\
Return the <gdb:type> object for the \"bool\" type\n\
of the architecture." },
{ "arch-longlong-type", 1, 0, 0, gdbscm_arch_longlong_type,
"\
Return the <gdb:type> object for the \"long long\" type\n\
of the architecture." },
{ "arch-ulonglong-type", 1, 0, 0,
gdbscm_arch_ulonglong_type,
"\
Return the <gdb:type> object for the \"unsigned long long\" type\n\
of the architecture." },
{ "arch-int8-type", 1, 0, 0, gdbscm_arch_int8_type,
"\
Return the <gdb:type> object for the \"int8\" type\n\
of the architecture." },
{ "arch-uint8-type", 1, 0, 0, gdbscm_arch_uint8_type,
"\
Return the <gdb:type> object for the \"uint8\" type\n\
of the architecture." },
{ "arch-int16-type", 1, 0, 0, gdbscm_arch_int16_type,
"\
Return the <gdb:type> object for the \"int16\" type\n\
of the architecture." },
{ "arch-uint16-type", 1, 0, 0, gdbscm_arch_uint16_type,
"\
Return the <gdb:type> object for the \"uint16\" type\n\
of the architecture." },
{ "arch-int32-type", 1, 0, 0, gdbscm_arch_int32_type,
"\
Return the <gdb:type> object for the \"int32\" type\n\
of the architecture." },
{ "arch-uint32-type", 1, 0, 0, gdbscm_arch_uint32_type,
"\
Return the <gdb:type> object for the \"uint32\" type\n\
of the architecture." },
{ "arch-int64-type", 1, 0, 0, gdbscm_arch_int64_type,
"\
Return the <gdb:type> object for the \"int64\" type\n\
of the architecture." },
{ "arch-uint64-type", 1, 0, 0, gdbscm_arch_uint64_type,
"\
Return the <gdb:type> object for the \"uint64\" type\n\
of the architecture." },
END_FUNCTIONS
};
void
gdbscm_initialize_arches (void)
{
arch_smob_tag = gdbscm_make_smob_type (arch_smob_name, sizeof (arch_smob));
scm_set_smob_mark (arch_smob_tag, arscm_mark_arch_smob);
scm_set_smob_print (arch_smob_tag, arscm_print_arch_smob);
gdbscm_define_functions (arch_functions, 1);
arch_object_data
= gdbarch_data_register_post_init (arscm_object_data_init);
}

81
gdb/guile/scm-auto-load.c Normal file
View File

@ -0,0 +1,81 @@
/* GDB routines for supporting auto-loaded Guile scripts.
Copyright (C) 2010-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/>. */
#include "defs.h"
#include <string.h>
#include "top.h"
#include "exceptions.h"
#include "gdbcmd.h"
#include "objfiles.h"
#include "cli/cli-cmds.h"
#include "auto-load.h"
#include "guile.h"
#include "guile-internal.h"
/* User-settable option to enable/disable auto-loading of Guile scripts:
set auto-load guile-scripts on|off
This is true if we should auto-load associated Guile scripts when an
objfile is opened, false otherwise. */
static int auto_load_guile_scripts = 1;
/* "show" command for the auto_load_guile_scripts configuration variable. */
static void
show_auto_load_guile_scripts (struct ui_file *file, int from_tty,
struct cmd_list_element *c, const char *value)
{
fprintf_filtered (file, _("Auto-loading of Guile scripts is %s.\n"), value);
}
/* Return non-zero if auto-loading Guile scripts is enabled.
This is the extension_language_script_ops.auto_load_enabled "method". */
int
gdbscm_auto_load_enabled (const struct extension_language_defn *extlang)
{
return auto_load_guile_scripts;
}
/* Wrapper for "info auto-load guile-scripts". */
static void
info_auto_load_guile_scripts (char *pattern, int from_tty)
{
auto_load_info_scripts (pattern, from_tty, &extension_language_guile);
}
void
gdbscm_initialize_auto_load (void)
{
add_setshow_boolean_cmd ("guile-scripts", class_support,
&auto_load_guile_scripts, _("\
Set the debugger's behaviour regarding auto-loaded Guile scripts."), _("\
Show the debugger's behaviour regarding auto-loaded Guile scripts."), _("\
If enabled, auto-loaded Guile scripts are loaded when the debugger reads\n\
an executable or shared library.\n\
This options has security implications for untrusted inferiors."),
NULL, show_auto_load_guile_scripts,
auto_load_set_cmdlist_get (),
auto_load_show_cmdlist_get ());
add_cmd ("guile-scripts", class_info, info_auto_load_guile_scripts,
_("Print the list of automatically loaded Guile scripts.\n\
Usage: info auto-load guile-scripts [REGEXP]"),
auto_load_info_cmdlist_get ());
}

828
gdb/guile/scm-block.c Normal file
View File

@ -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 <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));
}
/* Return the existing object that encapsulates BLOCK, or create a new
<gdb:block> 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 <gdb:block> object in SELF.
Throws an exception if SELF is not a <gdb:block> 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 <gdb:block> 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 <gdb:block> 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,
_("<gdb:block>"));
}
return b_smob;
}
/* Returns the block smob contained in SCM or NULL if SCM is not a
<gdb:block> object.
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;
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,
_("<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, then 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 != NULL)
return syscm_scm_from_symbol (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 (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 (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 (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 (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 ();
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) -> <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 (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);
}

1200
gdb/guile/scm-breakpoint.c Normal file

File diff suppressed because it is too large Load Diff

355
gdb/guile/scm-disasm.c Normal file
View File

@ -0,0 +1,355 @@
/* Scheme interface to architecture.
Copyright (C) 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 "arch-utils.h"
#include "disasm.h"
#include "dis-asm.h"
#include "gdbarch.h"
#include "gdbcore.h" /* Why is memory_error here? */
#include "guile-internal.h"
static SCM port_keyword;
static SCM offset_keyword;
static SCM size_keyword;
static SCM count_keyword;
static SCM address_symbol;
static SCM asm_symbol;
static SCM length_symbol;
/* Struct used to pass "application data" in disassemble_info. */
struct gdbscm_disasm_data
{
struct gdbarch *gdbarch;
SCM port;
/* The offset of the address of the first instruction in PORT. */
ULONGEST offset;
};
/* Struct used to pass data from gdbscm_disasm_read_memory to
gdbscm_disasm_read_memory_worker. */
struct gdbscm_disasm_read_data
{
bfd_vma memaddr;
bfd_byte *myaddr;
unsigned int length;
struct disassemble_info *dinfo;
};
/* Subroutine of gdbscm_arch_disassemble to simplify it.
Return the result for one instruction. */
static SCM
dascm_make_insn (CORE_ADDR pc, const char *assembly, int insn_len)
{
return scm_list_3 (scm_cons (address_symbol,
gdbscm_scm_from_ulongest (pc)),
scm_cons (asm_symbol,
gdbscm_scm_from_c_string (assembly)),
scm_cons (length_symbol,
scm_from_int (insn_len)));
}
/* Helper function for gdbscm_disasm_read_memory to safely read from a
Scheme port. Called via gdbscm_call_guile.
The result is a statically allocated error message or NULL if success. */
static void *
gdbscm_disasm_read_memory_worker (void *datap)
{
struct gdbscm_disasm_read_data *data = datap;
struct disassemble_info *dinfo = data->dinfo;
struct gdbscm_disasm_data *disasm_data = dinfo->application_data;
SCM seekto, newpos, port = disasm_data->port;
size_t bytes_read;
seekto = gdbscm_scm_from_ulongest (data->memaddr - disasm_data->offset);
newpos = scm_seek (port, seekto, scm_from_int (SEEK_SET));
if (!scm_is_eq (seekto, newpos))
return "seek error";
bytes_read = scm_c_read (port, data->myaddr, data->length);
if (bytes_read != data->length)
return "short read";
/* If we get here the read succeeded. */
return NULL;
}
/* disassemble_info.read_memory_func for gdbscm_print_insn_from_port. */
static int
gdbscm_disasm_read_memory (bfd_vma memaddr, bfd_byte *myaddr,
unsigned int length,
struct disassemble_info *dinfo)
{
struct gdbscm_disasm_read_data data;
void *status;
data.memaddr = memaddr;
data.myaddr = myaddr;
data.length = length;
data.dinfo = dinfo;
status = gdbscm_with_guile (gdbscm_disasm_read_memory_worker, &data);
/* TODO: IWBN to distinguish problems reading target memory versus problems
with the port (e.g., EOF).
We return TARGET_XFER_E_IO here as that's what memory_error looks for. */
return status != NULL ? TARGET_XFER_E_IO : 0;
}
/* disassemble_info.memory_error_func for gdbscm_print_insn_from_port.
Technically speaking, we don't need our own memory_error_func,
but to not provide one would leave a subtle dependency in the code.
This function exists to keep a clear boundary. */
static void
gdbscm_disasm_memory_error (int status, bfd_vma memaddr,
struct disassemble_info *info)
{
memory_error (status, memaddr);
}
/* disassemble_info.print_address_func for gdbscm_print_insn_from_port.
Since we need to use our own application_data value, we need to supply
this routine as well. */
static void
gdbscm_disasm_print_address (bfd_vma addr, struct disassemble_info *info)
{
struct gdbscm_disasm_data *data = info->application_data;
struct gdbarch *gdbarch = data->gdbarch;
print_address (gdbarch, addr, info->stream);
}
/* Subroutine of gdbscm_arch_disassemble to simplify it.
Call gdbarch_print_insn using a port for input.
PORT must be seekable.
OFFSET is the offset in PORT from which addresses begin.
For example, when printing from a bytevector, addresses passed to the
bv seek routines must be in the range [0,size). However, the bytevector
may represent an instruction at address 0x1234. To handle this case pass
0x1234 for OFFSET.
This is based on gdb_print_insn, see it for details. */
static int
gdbscm_print_insn_from_port (struct gdbarch *gdbarch,
SCM port, ULONGEST offset, CORE_ADDR memaddr,
struct ui_file *stream, int *branch_delay_insns)
{
struct disassemble_info di;
int length;
struct gdbscm_disasm_data data;
di = gdb_disassemble_info (gdbarch, stream);
data.gdbarch = gdbarch;
data.port = port;
data.offset = offset;
di.application_data = &data;
di.read_memory_func = gdbscm_disasm_read_memory;
di.memory_error_func = gdbscm_disasm_memory_error;
di.print_address_func = gdbscm_disasm_print_address;
length = gdbarch_print_insn (gdbarch, memaddr, &di);
if (branch_delay_insns)
{
if (di.insn_info_valid)
*branch_delay_insns = di.branch_delay_insns;
else
*branch_delay_insns = 0;
}
return length;
}
/* (arch-disassemble <gdb:arch> address
[#:port port] [#:offset address] [#:size integer] [#:count integer])
-> list
Returns a list of disassembled instructions.
If PORT is provided, read bytes from it. Otherwise read target memory.
If PORT is #f, read target memory.
PORT must be seekable. IWBN to remove this restriction, and a future
release may. For now the restriction is in place because it's not clear
all disassemblers are strictly sequential.
If SIZE is provided, limit the number of bytes read to this amount.
If COUNT is provided, limit the number of instructions to this amount.
Each instruction in the result is an alist:
(('address . address) ('asm . disassembly) ('length . length)).
We could use a hash table (dictionary) but there aren't that many fields. */
static SCM
gdbscm_arch_disassemble (SCM self, SCM start_scm, SCM rest)
{
arch_smob *a_smob
= arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct gdbarch *gdbarch = arscm_get_gdbarch (a_smob);
const SCM keywords[] = {
port_keyword, offset_keyword, size_keyword, count_keyword, SCM_BOOL_F
};
int port_arg_pos = -1, offset_arg_pos = -1;
int size_arg_pos = -1, count_arg_pos = -1;
SCM port = SCM_BOOL_F;
ULONGEST offset = 0;
unsigned int count = 1;
unsigned int size;
ULONGEST start_arg;
CORE_ADDR start, end;
CORE_ADDR pc;
unsigned int i;
int using_port;
SCM result;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "U#OUuu",
start_scm, &start_arg, rest,
&port_arg_pos, &port,
&offset_arg_pos, &offset,
&size_arg_pos, &size,
&count_arg_pos, &count);
/* START is first stored in a ULONGEST because we don't have a format char
for CORE_ADDR, and it's not really worth it to have one yet. */
start = start_arg;
if (port_arg_pos > 0)
{
SCM_ASSERT_TYPE (gdbscm_is_false (port)
|| gdbscm_is_true (scm_input_port_p (port)),
port, port_arg_pos, FUNC_NAME, _("input port"));
}
using_port = gdbscm_is_true (port);
if (offset_arg_pos > 0
&& (port_arg_pos < 0
|| gdbscm_is_false (port)))
{
gdbscm_out_of_range_error (FUNC_NAME, offset_arg_pos,
gdbscm_scm_from_ulongest (offset),
_("offset provided but port is missing"));
}
if (size_arg_pos > 0)
{
if (size == 0)
return SCM_EOL;
/* For now be strict about start+size overflowing. If it becomes
a nuisance we can relax things later. */
if (start + size < start)
{
gdbscm_out_of_range_error (FUNC_NAME, 0,
scm_list_2 (gdbscm_scm_from_ulongest (start),
gdbscm_scm_from_ulongest (size)),
_("start+size overflows"));
}
end = start + size - 1;
}
else
end = ~(CORE_ADDR) 0;
if (count == 0)
return SCM_EOL;
result = SCM_EOL;
for (pc = start, i = 0; pc <= end && i < count; )
{
int insn_len = 0;
char *as = NULL;
struct ui_file *memfile = mem_fileopen ();
struct cleanup *cleanups = make_cleanup_ui_file_delete (memfile);
volatile struct gdb_exception except;
TRY_CATCH (except, RETURN_MASK_ALL)
{
if (using_port)
{
insn_len = gdbscm_print_insn_from_port (gdbarch, port, offset,
pc, memfile, NULL);
}
else
insn_len = gdb_print_insn (gdbarch, pc, memfile, NULL);
}
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
as = ui_file_xstrdup (memfile, NULL);
result = scm_cons (dascm_make_insn (pc, as, insn_len),
result);
pc += insn_len;
i++;
do_cleanups (cleanups);
xfree (as);
}
return scm_reverse_x (result, SCM_EOL);
}
/* Initialize the Scheme architecture support. */
static const scheme_function disasm_functions[] =
{
{ "arch-disassemble", 2, 0, 1, gdbscm_arch_disassemble,
"\
Return list of disassembled instructions in memory.\n\
\n\
Arguments: <gdb:arch> start-address\n\
[#:port port] [#:offset address]\n\
[#:size <integer>] [#:count <integer>]\n\
port: If non-#f, it is an input port to read bytes from.\n\
offset: Specifies the address offset of the first byte in the port.\n\
This is useful if the input is from something other than memory\n\
(e.g., a bytevector) and you want the result to be as if the bytes\n\
came from that address. The value to pass for start-address is\n\
then also the desired disassembly address, not the offset in, e.g.,\n\
the bytevector.\n\
size: Limit the number of bytes read to this amount.\n\
count: Limit the number of instructions to this amount.\n\
\n\
Returns:\n\
Each instruction in the result is an alist:\n\
(('address . address) ('asm . disassembly) ('length . length))." },
END_FUNCTIONS
};
void
gdbscm_initialize_disasm (void)
{
gdbscm_define_functions (disasm_functions, 1);
port_keyword = scm_from_latin1_keyword ("port");
offset_keyword = scm_from_latin1_keyword ("offset");
size_keyword = scm_from_latin1_keyword ("size");
count_keyword = scm_from_latin1_keyword ("count");
address_symbol = scm_from_latin1_symbol ("address");
asm_symbol = scm_from_latin1_symbol ("asm");
length_symbol = scm_from_latin1_symbol ("length");
}

691
gdb/guile/scm-exception.c Normal file
View File

@ -0,0 +1,691 @@
/* GDB/Scheme exception support.
Copyright (C) 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. */
/* Notes:
IWBN to support SRFI 34/35. At the moment we follow Guile's own
exception mechanism.
The non-static functions in this file have prefix gdbscm_ and
not exscm_ on purpose. */
#include "defs.h"
#include <signal.h>
#include "gdb_assert.h"
#include "guile-internal.h"
/* The <gdb:exception> smob.
This is used to record and handle Scheme exceptions.
One important invariant is that <gdb:exception> smobs are never a valid
result of a function, other than to signify an exception occurred. */
typedef struct
{
/* This always appears first. */
gdb_smob base;
/* The key and args parameters to "throw". */
SCM key;
SCM args;
} exception_smob;
static const char exception_smob_name[] = "gdb:exception";
/* The tag Guile knows the exception smob by. */
static scm_t_bits exception_smob_tag;
/* A generic error in struct gdb_exception.
I.e., not RETURN_QUIT and not MEMORY_ERROR. */
static SCM error_symbol;
/* An error occurred accessing inferior memory.
This is not a Scheme programming error. */
static SCM memory_error_symbol;
/* User interrupt, e.g., RETURN_QUIT in struct gdb_exception. */
static SCM signal_symbol;
/* Printing the stack is done by first capturing the stack and recording it in
a <gdb:exception> object with this key and with the ARGS field set to
(cons real-key (cons stack real-args)).
See gdbscm_make_exception_with_stack. */
static SCM with_stack_error_symbol;
/* The key to use for an invalid object exception. An invalid object is one
where the underlying object has been removed from GDB. */
SCM gdbscm_invalid_object_error_symbol;
/* Values for "guile print-stack" as symbols. */
static SCM none_symbol;
static SCM message_symbol;
static SCM full_symbol;
static const char percent_print_exception_message_name[] =
"%print-exception-message";
/* Variable containing %print-exception-message.
It is not defined until late in initialization, after our init routine
has run. Cope by looking it up lazily. */
static SCM percent_print_exception_message_var = SCM_BOOL_F;
static const char percent_print_exception_with_stack_name[] =
"%print-exception-with-stack";
/* Variable containing %print-exception-with-stack.
It is not defined until late in initialization, after our init routine
has run. Cope by looking it up lazily. */
static SCM percent_print_exception_with_stack_var = SCM_BOOL_F;
/* Counter to keep track of the number of times we create a <gdb:exception>
object, for performance monitoring purposes. */
static unsigned long gdbscm_exception_count = 0;
/* Administrivia for exception smobs. */
/* The smob "mark" function for <gdb:exception>. */
static SCM
exscm_mark_exception_smob (SCM self)
{
exception_smob *e_smob = (exception_smob *) SCM_SMOB_DATA (self);
scm_gc_mark (e_smob->key);
scm_gc_mark (e_smob->args);
/* Do this last. */
return gdbscm_mark_gsmob (&e_smob->base);
}
/* The smob "print" function for <gdb:exception>. */
static int
exscm_print_exception_smob (SCM self, SCM port, scm_print_state *pstate)
{
exception_smob *e_smob = (exception_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", exception_smob_name);
scm_write (e_smob->key, port);
scm_puts (" ", port);
scm_write (e_smob->args, port);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* (make-exception key args) -> <gdb:exception> */
SCM
gdbscm_make_exception (SCM key, SCM args)
{
exception_smob *e_smob = (exception_smob *)
scm_gc_malloc (sizeof (exception_smob), exception_smob_name);
SCM smob;
e_smob->key = key;
e_smob->args = args;
smob = scm_new_smob (exception_smob_tag, (scm_t_bits) e_smob);
gdbscm_init_gsmob (&e_smob->base);
++gdbscm_exception_count;
return smob;
}
/* Return non-zero if SCM is a <gdb:exception> object. */
int
gdbscm_is_exception (SCM scm)
{
return SCM_SMOB_PREDICATE (exception_smob_tag, scm);
}
/* (exception? scm) -> boolean */
static SCM
gdbscm_exception_p (SCM scm)
{
return scm_from_bool (gdbscm_is_exception (scm));
}
/* (exception-key <gdb:exception>) -> key */
SCM
gdbscm_exception_key (SCM self)
{
exception_smob *e_smob;
SCM_ASSERT_TYPE (gdbscm_is_exception (self), self, SCM_ARG1, FUNC_NAME,
"gdb:exception");
e_smob = (exception_smob *) SCM_SMOB_DATA (self);
return e_smob->key;
}
/* (exception-args <gdb:exception>) -> arg-list */
SCM
gdbscm_exception_args (SCM self)
{
exception_smob *e_smob;
SCM_ASSERT_TYPE (gdbscm_is_exception (self), self, SCM_ARG1, FUNC_NAME,
"gdb:exception");
e_smob = (exception_smob *) SCM_SMOB_DATA (self);
return e_smob->args;
}
/* Wrap an exception in a <gdb:exception> object that includes STACK.
gdbscm_print_exception_with_stack knows how to unwrap it. */
SCM
gdbscm_make_exception_with_stack (SCM key, SCM args, SCM stack)
{
return gdbscm_make_exception (with_stack_error_symbol,
scm_cons (key, scm_cons (stack, args)));
}
/* Version of scm_error_scm that creates a gdb:exception object that can later
be passed to gdbscm_throw.
KEY is a symbol denoting the kind of error.
SUBR is either #f or a string marking the function in which the error
occurred.
MESSAGE is either #f or the error message string. It may contain ~a and ~s
modifiers, provided by ARGS.
ARGS is a list of args to MESSAGE.
DATA is an arbitrary object, its value depends on KEY. The value to pass
here is a bit underspecified by Guile. */
SCM
gdbscm_make_error_scm (SCM key, SCM subr, SCM message, SCM args, SCM data)
{
return gdbscm_make_exception (key, scm_list_4 (subr, message, args, data));
}
/* Version of scm_error that creates a gdb:exception object that can later
be passed to gdbscm_throw.
See gdbscm_make_error_scm for a description of the arguments. */
SCM
gdbscm_make_error (SCM key, const char *subr, const char *message,
SCM args, SCM data)
{
return gdbscm_make_error_scm
(key,
subr == NULL ? SCM_BOOL_F : scm_from_latin1_string (subr),
message == NULL ? SCM_BOOL_F : scm_from_latin1_string (message),
args, data);
}
/* Version of SCM_ASSERT_TYPE/scm_wrong_type_arg_msg that creates a
gdb:exception object that can later be passed to gdbscm_throw. */
SCM
gdbscm_make_type_error (const char *subr, int arg_pos, SCM bad_value,
const char *expected_type)
{
char *msg;
SCM result;
if (arg_pos > 0)
{
if (expected_type != NULL)
{
msg = xstrprintf (_("Wrong type argument in position %d"
" (expecting %s): ~S"),
arg_pos, expected_type);
}
else
{
msg = xstrprintf (_("Wrong type argument in position %d: ~S"),
arg_pos);
}
}
else
{
if (expected_type != NULL)
{
msg = xstrprintf (_("Wrong type argument (expecting %s): ~S"),
expected_type);
}
else
msg = xstrprintf (_("Wrong type argument: ~S"));
}
result = gdbscm_make_error (scm_arg_type_key, subr, msg,
scm_list_1 (bad_value), scm_list_1 (bad_value));
xfree (msg);
return result;
}
/* A variant of gdbscm_make_type_error for non-type argument errors.
ERROR_PREFIX and ERROR are combined to build the error message.
Care needs to be taken so that the i18n composed form is still
reasonable, but no one is going to translate these anyway so we don't
worry too much.
ERROR_PREFIX may be NULL, ERROR may not be NULL. */
static SCM
gdbscm_make_arg_error (SCM key, const char *subr, int arg_pos, SCM bad_value,
const char *error_prefix, const char *error)
{
char *msg;
SCM result;
if (error_prefix != NULL)
{
if (arg_pos > 0)
{
msg = xstrprintf (_("%s %s in position %d: ~S"),
error_prefix, error, arg_pos);
}
else
msg = xstrprintf (_("%s %s: ~S"), error_prefix, error);
}
else
{
if (arg_pos > 0)
msg = xstrprintf (_("%s in position %d: ~S"), error, arg_pos);
else
msg = xstrprintf (_("%s: ~S"), error);
}
result = gdbscm_make_error (key, subr, msg,
scm_list_1 (bad_value), scm_list_1 (bad_value));
xfree (msg);
return result;
}
/* Make an invalid-object error <gdb:exception> object.
OBJECT is the name of the kind of object that is invalid. */
SCM
gdbscm_make_invalid_object_error (const char *subr, int arg_pos, SCM bad_value,
const char *object)
{
return gdbscm_make_arg_error (gdbscm_invalid_object_error_symbol,
subr, arg_pos, bad_value,
_("Invalid object:"), object);
}
/* Throw an invalid-object error.
OBJECT is the name of the kind of object that is invalid. */
SCM
gdbscm_invalid_object_error (const char *subr, int arg_pos, SCM bad_value,
const char *object)
{
SCM exception
= gdbscm_make_invalid_object_error (subr, arg_pos, bad_value, object);
gdbscm_throw (exception);
}
/* Make an out-of-range error <gdb:exception> object. */
SCM
gdbscm_make_out_of_range_error (const char *subr, int arg_pos, SCM bad_value,
const char *error)
{
return gdbscm_make_arg_error (scm_out_of_range_key,
subr, arg_pos, bad_value,
_("Out of range:"), error);
}
/* Throw an out-of-range error.
This is the standard Guile out-of-range exception. */
SCM
gdbscm_out_of_range_error (const char *subr, int arg_pos, SCM bad_value,
const char *error)
{
SCM exception
= gdbscm_make_out_of_range_error (subr, arg_pos, bad_value, error);
gdbscm_throw (exception);
}
/* Make a misc-error <gdb:exception> object. */
SCM
gdbscm_make_misc_error (const char *subr, int arg_pos, SCM bad_value,
const char *error)
{
return gdbscm_make_arg_error (scm_misc_error_key,
subr, arg_pos, bad_value, NULL, error);
}
/* Return a <gdb:exception> object for gdb:memory-error. */
SCM
gdbscm_make_memory_error (const char *subr, const char *msg, SCM args)
{
return gdbscm_make_error (memory_error_symbol, subr, msg, args,
SCM_EOL);
}
/* Throw a gdb:memory-error exception. */
SCM
gdbscm_memory_error (const char *subr, const char *msg, SCM args)
{
SCM exception = gdbscm_make_memory_error (subr, msg, args);
gdbscm_throw (exception);
}
/* Return non-zero if KEY is gdb:memory-error.
Note: This is an excp_matcher_func function. */
int
gdbscm_memory_error_p (SCM key)
{
return scm_is_eq (key, memory_error_symbol);
}
/* Wrapper around scm_throw to throw a gdb:exception.
This function does not return.
This function cannot be called from inside TRY_CATCH. */
void
gdbscm_throw (SCM exception)
{
scm_throw (gdbscm_exception_key (exception),
gdbscm_exception_args (exception));
gdb_assert_not_reached ("scm_throw returned");
}
/* Convert a GDB exception to a <gdb:exception> object. */
SCM
gdbscm_scm_from_gdb_exception (struct gdb_exception exception)
{
SCM key;
if (exception.reason == RETURN_QUIT)
{
/* Handle this specially to be consistent with top-repl.scm. */
return gdbscm_make_error (signal_symbol, NULL, _("User interrupt"),
SCM_EOL, scm_list_1 (scm_from_int (SIGINT)));
}
if (exception.error == MEMORY_ERROR)
key = memory_error_symbol;
else
key = error_symbol;
return gdbscm_make_error (key, NULL, "~A",
scm_list_1 (gdbscm_scm_from_c_string
(exception.message)),
SCM_BOOL_F);
}
/* Convert a GDB exception to the appropriate Scheme exception and throw it.
This function does not return. */
void
gdbscm_throw_gdb_exception (struct gdb_exception exception)
{
gdbscm_throw (gdbscm_scm_from_gdb_exception (exception));
}
/* Print the error message portion of an exception.
If PORT is #f, use the standard error port.
KEY cannot be gdb:with-stack.
Basically this function is just a wrapper around calling
%print-exception-message. */
static void
gdbscm_print_exception_message (SCM port, SCM frame, SCM key, SCM args)
{
SCM printer, status;
if (gdbscm_is_false (port))
port = scm_current_error_port ();
gdb_assert (!scm_is_eq (key, with_stack_error_symbol));
/* This does not use scm_print_exception because we tweak the output a bit.
Compare Guile's print-exception with our %print-exception-message for
details. */
if (gdbscm_is_false (percent_print_exception_message_var))
{
percent_print_exception_message_var
= scm_c_private_variable (gdbscm_init_module_name,
percent_print_exception_message_name);
/* If we can't find %print-exception-message, there's a problem on the
Scheme side. Don't kill GDB, just flag an error and leave it at
that. */
if (gdbscm_is_false (percent_print_exception_message_var))
{
gdbscm_printf (port, _("Error in Scheme exception printing,"
" can't find %s.\n"),
percent_print_exception_message_name);
return;
}
}
printer = scm_variable_ref (percent_print_exception_message_var);
status = gdbscm_safe_call_4 (printer, port, frame, key, args, NULL);
/* If that failed still tell the user something.
But don't use the exception printing machinery! */
if (gdbscm_is_exception (status))
{
gdbscm_printf (port, _("Error in Scheme exception printing:\n"));
scm_display (status, port);
scm_newline (port);
}
}
/* Print the description of exception KEY, ARGS to PORT, according to the
setting of "set guile print-stack".
If PORT is #f, use the standard error port.
If STACK is #f, never print the stack, regardless of whether printing it
is enabled. If STACK is #t, then print it if it is contained in ARGS
(i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
scm_make_stack (which will be ignored in favor of the stack in ARGS if
KEY is gdb:with-stack).
KEY, ARGS are the standard arguments to scm_throw, et.al.
Basically this function is just a wrapper around calling
%print-exception-with-args. */
void
gdbscm_print_exception_with_stack (SCM port, SCM stack, SCM key, SCM args)
{
SCM printer, status;
if (gdbscm_is_false (port))
port = scm_current_error_port ();
if (gdbscm_is_false (percent_print_exception_with_stack_var))
{
percent_print_exception_with_stack_var
= scm_c_private_variable (gdbscm_init_module_name,
percent_print_exception_with_stack_name);
/* If we can't find %print-exception-with-args, there's a problem on the
Scheme side. Don't kill GDB, just flag an error and leave it at
that. */
if (gdbscm_is_false (percent_print_exception_with_stack_var))
{
gdbscm_printf (port, _("Error in Scheme exception printing,"
" can't find %s.\n"),
percent_print_exception_with_stack_name);
return;
}
}
printer = scm_variable_ref (percent_print_exception_with_stack_var);
status = gdbscm_safe_call_4 (printer, port, stack, key, args, NULL);
/* If that failed still tell the user something.
But don't use the exception printing machinery! */
if (gdbscm_is_exception (status))
{
gdbscm_printf (port, _("Error in Scheme exception printing:\n"));
scm_display (status, port);
scm_newline (port);
}
}
/* Print EXCEPTION, a <gdb:exception> object, to PORT.
If PORT is #f, use the standard error port. */
void
gdbscm_print_gdb_exception (SCM port, SCM exception)
{
gdb_assert (gdbscm_is_exception (exception));
gdbscm_print_exception_with_stack (port, SCM_BOOL_T,
gdbscm_exception_key (exception),
gdbscm_exception_args (exception));
}
/* Return a string description of <gdb:exception> EXCEPTION.
If EXCEPTION is a gdb:with-stack exception, unwrap it, a backtrace
is never returned as part of the result.
Space for the result is malloc'd, the caller must free. */
char *
gdbscm_exception_message_to_string (SCM exception)
{
SCM port = scm_open_output_string ();
SCM key, args;
char *result;
gdb_assert (gdbscm_is_exception (exception));
key = gdbscm_exception_key (exception);
args = gdbscm_exception_args (exception);
if (scm_is_eq (key, with_stack_error_symbol)
/* Don't crash on a badly generated gdb:with-stack exception. */
&& scm_is_pair (args)
&& scm_is_pair (scm_cdr (args)))
{
key = scm_car (args);
args = scm_cddr (args);
}
gdbscm_print_exception_message (port, SCM_BOOL_F, key, args);
result = gdbscm_scm_to_c_string (scm_get_output_string (port));
scm_close_port (port);
return result;
}
/* Return the value of the "guile print-stack" option as one of:
'none, 'message, 'full. */
static SCM
gdbscm_percent_exception_print_style (void)
{
if (gdbscm_print_excp == gdbscm_print_excp_none)
return none_symbol;
if (gdbscm_print_excp == gdbscm_print_excp_message)
return message_symbol;
if (gdbscm_print_excp == gdbscm_print_excp_full)
return full_symbol;
gdb_assert_not_reached ("bad value for \"guile print-stack\"");
}
/* Return the current <gdb:exception> counter.
This is for debugging purposes. */
static SCM
gdbscm_percent_exception_count (void)
{
return scm_from_ulong (gdbscm_exception_count);
}
/* Initialize the Scheme exception support. */
static const scheme_function exception_functions[] =
{
{ "make-exception", 2, 0, 0, gdbscm_make_exception,
"\
Create a <gdb:exception> object.\n\
\n\
Arguments: key args\n\
These are the standard key,args arguments of \"throw\"." },
{ "exception?", 1, 0, 0, gdbscm_exception_p,
"\
Return #t if the object is a <gdb:exception> object." },
{ "exception-key", 1, 0, 0, gdbscm_exception_key,
"\
Return the exception's key." },
{ "exception-args", 1, 0, 0, gdbscm_exception_args,
"\
Return the exception's arg list." },
END_FUNCTIONS
};
static const scheme_function private_exception_functions[] =
{
{ "%exception-print-style", 0, 0, 0, gdbscm_percent_exception_print_style,
"\
Return the value of the \"guile print-stack\" option." },
{ "%exception-count", 0, 0, 0, gdbscm_percent_exception_count,
"\
Return a count of the number of <gdb:exception> objects created.\n\
This is for debugging purposes." },
END_FUNCTIONS
};
void
gdbscm_initialize_exceptions (void)
{
exception_smob_tag = gdbscm_make_smob_type (exception_smob_name,
sizeof (exception_smob));
scm_set_smob_mark (exception_smob_tag, exscm_mark_exception_smob);
scm_set_smob_print (exception_smob_tag, exscm_print_exception_smob);
gdbscm_define_functions (exception_functions, 1);
gdbscm_define_functions (private_exception_functions, 0);
error_symbol = scm_from_latin1_symbol ("gdb:error");
memory_error_symbol = scm_from_latin1_symbol ("gdb:memory-error");
gdbscm_invalid_object_error_symbol
= scm_from_latin1_symbol ("gdb:invalid-object-error");
with_stack_error_symbol = scm_from_latin1_symbol ("gdb:with-stack");
/* The text of this symbol is taken from Guile's top-repl.scm. */
signal_symbol = scm_from_latin1_symbol ("signal");
none_symbol = scm_from_latin1_symbol ("none");
message_symbol = scm_from_latin1_symbol ("message");
full_symbol = scm_from_latin1_symbol ("full");
}

1077
gdb/guile/scm-frame.c Normal file

File diff suppressed because it is too large Load Diff

486
gdb/guile/scm-gsmob.c Normal file
View File

@ -0,0 +1,486 @@
/* GDB/Scheme smobs (gsmob is pronounced "jee smob")
Copyright (C) 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. */
/* Smobs are Guile's "small object".
They are used to export C structs to Scheme.
Note: There's only room in the encoding space for 256, and while we won't
come close to that, mixed with other libraries maybe someday we could.
We don't worry about it now, except to be aware of the issue.
We could allocate just a few smobs and use the unused smob flags field to
specify the gdb smob kind, that is left for another day if it ever is
needed.
We want the objects we export to Scheme to be extensible by the user.
A gsmob (gdb smob) adds a simple API on top of smobs to support this.
This allows GDB objects to be easily extendable in a useful manner.
To that end, all smobs in gdb have gdb_smob as the first member.
On top of gsmobs there are "chained gsmobs". They are used to assist with
life-time tracking of GDB objects vs Scheme objects. Gsmobs can "subclass"
chained_gdb_smob, which contains a doubly-linked list to assist with
life-time tracking.
On top of gsmobs there are also "eqable gsmobs". Gsmobs can "subclass"
eqable_gdb_smob instead of gdb_smob, and is used to make gsmobs eq?-able.
This is done by recording all gsmobs in a hash table and before creating a
gsmob first seeing if it's already in the table. Eqable gsmobs can also be
used where lifetime-tracking is required.
Gsmobs (and chained/eqable gsmobs) add an extra field that is used to
record extra data: "properties". It is a table of key/value pairs
that can be set with set-gsmob-property!, gsmob-property. */
#include "defs.h"
#include "hashtab.h"
#include "gdb_assert.h"
#include "objfiles.h"
#include "guile-internal.h"
/* We need to call this. Undo our hack to prevent others from calling it. */
#undef scm_make_smob_type
static htab_t registered_gsmobs;
/* Gsmob properties are initialize stored as an alist to minimize space
usage: GDB can be used to debug some really big programs, and property
lists generally have very few elements. Once the list grows to this
many elements then we switch to a hash table.
The smallest Guile hashtable in 2.0 uses a vector of 31 elements.
The value we use here is large enough to hold several expected uses,
without being so large that we might as well just use a hashtable. */
#define SMOB_PROP_HTAB_THRESHOLD 7
/* Hash function for registered_gsmobs hash table. */
static hashval_t
hash_scm_t_bits (const void *item)
{
uintptr_t v = (uintptr_t) item;
return v;
}
/* Equality function for registered_gsmobs hash table. */
static int
eq_scm_t_bits (const void *item_lhs, const void *item_rhs)
{
return item_lhs == item_rhs;
}
/* Record GSMOB_CODE as being a gdb smob.
GSMOB_CODE is the result of scm_make_smob_type. */
static void
register_gsmob (scm_t_bits gsmob_code)
{
void **slot;
slot = htab_find_slot (registered_gsmobs, (void *) gsmob_code, INSERT);
gdb_assert (*slot == NULL);
*slot = (void *) gsmob_code;
}
/* Return non-zero if SCM is any registered gdb smob object. */
static int
gdbscm_is_gsmob (SCM scm)
{
void **slot;
if (SCM_IMP (scm))
return 0;
slot = htab_find_slot (registered_gsmobs, (void *) SCM_TYP16 (scm),
NO_INSERT);
return slot != NULL;
}
/* Call this to register a smob, instead of scm_make_smob_type. */
scm_t_bits
gdbscm_make_smob_type (const char *name, size_t size)
{
scm_t_bits result = scm_make_smob_type (name, size);
register_gsmob (result);
return result;
}
/* Initialize a gsmob. */
void
gdbscm_init_gsmob (gdb_smob *base)
{
base->properties = SCM_EOL;
}
/* Initialize a chained_gdb_smob.
This is the same as gdbscm_init_gsmob except that it also sets prev,next
to NULL. */
void
gdbscm_init_chained_gsmob (chained_gdb_smob *base)
{
gdbscm_init_gsmob ((gdb_smob *) base);
base->prev = NULL;
base->next = NULL;
}
/* Initialize an eqable_gdb_smob.
This is the same as gdbscm_init_gsmob except that it also sets
containing_scm to #f. */
void
gdbscm_init_eqable_gsmob (eqable_gdb_smob *base)
{
gdbscm_init_gsmob ((gdb_smob *) base);
base->containing_scm = SCM_BOOL_F;
}
/* Call this from each smob's "mark" routine.
In general, this should be called as:
return gdbscm_mark_gsmob (base); */
SCM
gdbscm_mark_gsmob (gdb_smob *base)
{
/* Return the last one to mark as an optimization.
The marking infrastructure will mark it for us. */
return base->properties;
}
/* Call this from each smob's "mark" routine.
In general, this should be called as:
return gdbscm_mark_chained_gsmob (base); */
SCM
gdbscm_mark_chained_gsmob (chained_gdb_smob *base)
{
/* Return the last one to mark as an optimization.
The marking infrastructure will mark it for us. */
return base->properties;
}
/* Call this from each smob's "mark" routine.
In general, this should be called as:
return gdbscm_mark_eqable_gsmob (base); */
SCM
gdbscm_mark_eqable_gsmob (eqable_gdb_smob *base)
{
/* There's no need to mark containing_scm.
Any references to it either come from Scheme in which case it will be
marked through them, or there's a reference to the smob from gdb in
which case the smob is GC-protected. */
/* Return the last one to mark as an optimization.
The marking infrastructure will mark it for us. */
return base->properties;
}
/* gsmob accessors */
/* Return the gsmob in SELF.
Throws an exception if SELF is not a gsmob. */
static SCM
gsscm_get_gsmob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (gdbscm_is_gsmob (self), self, arg_pos, func_name,
_("any gdb smob"));
return self;
}
/* (gsmob-kind gsmob) -> symbol
Note: While one might want to name this gsmob-class-name, it is named
"-kind" because smobs aren't real GOOPS classes. */
static SCM
gdbscm_gsmob_kind (SCM self)
{
SCM smob, result;
scm_t_bits smobnum;
const char *name;
char *kind;
smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
smobnum = SCM_SMOBNUM (smob);
name = SCM_SMOBNAME (smobnum);
kind = xstrprintf ("<%s>", name);
result = scm_from_latin1_symbol (kind);
xfree (kind);
return result;
}
/* (gsmob-property gsmob property) -> object
If property isn't present then #f is returned. */
static SCM
gdbscm_gsmob_property (SCM self, SCM property)
{
SCM smob;
gdb_smob *base;
smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
base = (gdb_smob *) SCM_SMOB_DATA (self);
/* Have we switched to a hash table? */
if (gdbscm_is_true (scm_hash_table_p (base->properties)))
return scm_hashq_ref (base->properties, property, SCM_BOOL_F);
return scm_assq_ref (base->properties, property);
}
/* (set-gsmob-property! gsmob property new-value) -> unspecified */
static SCM
gdbscm_set_gsmob_property_x (SCM self, SCM property, SCM new_value)
{
SCM smob, alist;
gdb_smob *base;
smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
base = (gdb_smob *) SCM_SMOB_DATA (self);
/* Have we switched to a hash table? */
if (gdbscm_is_true (scm_hash_table_p (base->properties)))
{
scm_hashq_set_x (base->properties, property, new_value);
return SCM_UNSPECIFIED;
}
alist = scm_assq_set_x (base->properties, property, new_value);
/* Did we grow the list? */
if (!scm_is_eq (alist, base->properties))
{
/* If we grew the list beyond a threshold in size,
switch to a hash table. */
if (scm_ilength (alist) >= SMOB_PROP_HTAB_THRESHOLD)
{
SCM elm, htab;
htab = scm_c_make_hash_table (SMOB_PROP_HTAB_THRESHOLD);
for (elm = alist; elm != SCM_EOL; elm = scm_cdr (elm))
scm_hashq_set_x (htab, scm_caar (elm), scm_cdar (elm));
base->properties = htab;
return SCM_UNSPECIFIED;
}
}
base->properties = alist;
return SCM_UNSPECIFIED;
}
/* (gsmob-has-property? gsmob property) -> boolean */
static SCM
gdbscm_gsmob_has_property_p (SCM self, SCM property)
{
SCM smob, handle;
gdb_smob *base;
smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
base = (gdb_smob *) SCM_SMOB_DATA (self);
if (gdbscm_is_true (scm_hash_table_p (base->properties)))
handle = scm_hashq_get_handle (base->properties, property);
else
handle = scm_assq (property, base->properties);
return scm_from_bool (gdbscm_is_true (handle));
}
/* Helper function for gdbscm_gsmob_properties. */
static SCM
add_property_name (void *closure, SCM handle)
{
SCM *resultp = closure;
*resultp = scm_cons (scm_car (handle), *resultp);
return SCM_UNSPECIFIED;
}
/* (gsmob-properties gsmob) -> list
The list is unsorted. */
static SCM
gdbscm_gsmob_properties (SCM self)
{
SCM smob, handle, result;
gdb_smob *base;
smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
base = (gdb_smob *) SCM_SMOB_DATA (self);
result = SCM_EOL;
if (gdbscm_is_true (scm_hash_table_p (base->properties)))
{
scm_internal_hash_for_each_handle (add_property_name, &result,
base->properties);
}
else
{
SCM elm;
for (elm = base->properties; elm != SCM_EOL; elm = scm_cdr (elm))
result = scm_cons (scm_caar (elm), result);
}
return result;
}
/* When underlying gdb data structures are deleted, we need to update any
smobs with references to them. There are several smobs that reference
objfile-based data, so we provide helpers to manage this. */
/* Add G_SMOB to the reference chain for OBJFILE specified by DATA_KEY.
OBJFILE may be NULL, in which case just set prev,next to NULL. */
void
gdbscm_add_objfile_ref (struct objfile *objfile,
const struct objfile_data *data_key,
chained_gdb_smob *g_smob)
{
g_smob->prev = NULL;
if (objfile != NULL)
{
g_smob->next = objfile_data (objfile, data_key);
if (g_smob->next)
g_smob->next->prev = g_smob;
set_objfile_data (objfile, data_key, g_smob);
}
else
g_smob->next = NULL;
}
/* Remove G_SMOB from the reference chain for OBJFILE specified
by DATA_KEY. OBJFILE may be NULL. */
void
gdbscm_remove_objfile_ref (struct objfile *objfile,
const struct objfile_data *data_key,
chained_gdb_smob *g_smob)
{
if (g_smob->prev)
g_smob->prev->next = g_smob->next;
else if (objfile != NULL)
set_objfile_data (objfile, data_key, g_smob->next);
if (g_smob->next)
g_smob->next->prev = g_smob->prev;
}
/* Create a hash table for mapping a pointer to a gdb data structure to the
gsmob that wraps it. */
htab_t
gdbscm_create_eqable_gsmob_ptr_map (htab_hash hash_fn, htab_eq eq_fn)
{
htab_t htab = htab_create_alloc (7, hash_fn, eq_fn,
NULL, xcalloc, xfree);
return htab;
}
/* Return a pointer to the htab entry for the eq?-able gsmob BASE.
If the entry is found, *SLOT is non-NULL.
Otherwise *slot is NULL. */
eqable_gdb_smob **
gdbscm_find_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
{
void **slot = htab_find_slot (htab, base, INSERT);
return (eqable_gdb_smob **) slot;
}
/* Record CONTAINING_SCM as the object containing BASE, and record it in
SLOT. SLOT must be the result of calling gdbscm_find_eqable_gsmob_ptr_slot
on BASE (or equivalent for lookup). */
void
gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot,
eqable_gdb_smob *base,
SCM containing_scm)
{
base->containing_scm = containing_scm;
*slot = base;
}
/* Remove BASE from HTAB.
BASE is a pointer to a gsmob that wraps a pointer to a GDB datum.
This is used, for example, when an object is freed.
It is an error to call this if PTR is not in HTAB (only because it allows
for some consistency checking). */
void
gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
{
void **slot = htab_find_slot (htab, base, NO_INSERT);
gdb_assert (slot != NULL);
htab_clear_slot (htab, slot);
}
/* Initialize the Scheme gsmobs code. */
static const scheme_function gsmob_functions[] =
{
{ "gsmob-kind", 1, 0, 0, gdbscm_gsmob_kind,
"\
Return the kind of the smob, e.g., <gdb:breakpoint>, as a symbol." },
{ "gsmob-property", 2, 0, 0, gdbscm_gsmob_property,
"\
Return the specified property of the gsmob." },
{ "set-gsmob-property!", 3, 0, 0, gdbscm_set_gsmob_property_x,
"\
Set the specified property of the gsmob." },
{ "gsmob-has-property?", 2, 0, 0, gdbscm_gsmob_has_property_p,
"\
Return #t if the specified property is present." },
{ "gsmob-properties", 1, 0, 0, gdbscm_gsmob_properties,
"\
Return an unsorted list of names of properties." },
END_FUNCTIONS
};
void
gdbscm_initialize_smobs (void)
{
registered_gsmobs = htab_create_alloc (10,
hash_scm_t_bits, eq_scm_t_bits,
NULL, xcalloc, xfree);
gdbscm_define_functions (gsmob_functions, 1);
}

375
gdb/guile/scm-iterator.c Normal file
View File

@ -0,0 +1,375 @@
/* Simple iterators for GDB/Scheme.
Copyright (C) 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. */
/* These are *simple* iterators, used to implement iterating over a collection
of objects. They are implemented as a smob containing three objects:
1) the object being iterated over,
2) an object to record the progress of the iteration,
3) a procedure of one argument (the iterator object) that returns the next
object in the iteration or a pre-determined end marker.
Simple example:
(define-public (make-list-iterator l end-marker)
"Return a <gdb:iterator> object for a list."
(let ((next! (lambda (iter)
(let ((l (iterator-progress iter)))
(if (eq? l '())
end-marker
(begin
(set-iterator-progress! iter (cdr l))
(car l)))))))
(make-iterator l l next!)))
(define l '(1 2))
(define i (make-list-iterator l #:eoi))
(iterator-next! i) -> 1
(iterator-next! i) -> 2
(iterator-next! i) -> #:eoi
There is SRFI 41, Streams. We might support that too eventually (not with
this interface of course). */
#include "defs.h"
#include "guile-internal.h"
/* A smob for iterating over something.
Typically this is used when computing a list of everything is
too expensive.
The typedef for this struct is in guile-internal.h. */
struct _iterator_smob
{
/* This always appears first. */
gdb_smob base;
/* The object being iterated over. */
SCM object;
/* An arbitrary object describing the progress of the iteration.
This is used by next_x to track progress. */
SCM progress;
/* A procedure of one argument, the iterator.
It returns the next object in the iteration.
How to signal "end of iteration" is up to next_x. */
SCM next_x;
};
static const char iterator_smob_name[] = "gdb:iterator";
/* The tag Guile knows the iterator smob by. */
static scm_t_bits iterator_smob_tag;
/* A unique-enough marker to denote "end of iteration". */
static SCM end_of_iteration;
const char *
itscm_iterator_smob_name (void)
{
return iterator_smob_name;
}
SCM
itscm_iterator_smob_object (iterator_smob *i_smob)
{
return i_smob->object;
}
SCM
itscm_iterator_smob_progress (iterator_smob *i_smob)
{
return i_smob->progress;
}
void
itscm_set_iterator_smob_progress_x (iterator_smob *i_smob, SCM progress)
{
i_smob->progress = progress;
}
/* Administrivia for iterator smobs. */
/* The smob "mark" function for <gdb:iterator>. */
static SCM
itscm_mark_iterator_smob (SCM self)
{
iterator_smob *i_smob = (iterator_smob *) SCM_SMOB_DATA (self);
scm_gc_mark (i_smob->object);
scm_gc_mark (i_smob->progress);
scm_gc_mark (i_smob->next_x);
/* Do this last. */
return gdbscm_mark_gsmob (&i_smob->base);
}
/* The smob "print" function for <gdb:iterator>. */
static int
itscm_print_iterator_smob (SCM self, SCM port, scm_print_state *pstate)
{
iterator_smob *i_smob = (iterator_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", iterator_smob_name);
scm_write (i_smob->object, port);
scm_puts (" ", port);
scm_write (i_smob->progress, port);
scm_puts (" ", port);
scm_write (i_smob->next_x, port);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* Low level routine to make a <gdb:iterator> object.
Caller must verify correctness of arguments.
No exceptions are thrown. */
static SCM
itscm_make_iterator_smob (SCM object, SCM progress, SCM next)
{
iterator_smob *i_smob = (iterator_smob *)
scm_gc_malloc (sizeof (iterator_smob), iterator_smob_name);
SCM i_scm;
i_smob->object = object;
i_smob->progress = progress;
i_smob->next_x = next;
i_scm = scm_new_smob (iterator_smob_tag, (scm_t_bits) i_smob);
gdbscm_init_gsmob (&i_smob->base);
return i_scm;
}
/* (make-iterator object object procedure) -> <gdb:iterator> */
SCM
gdbscm_make_iterator (SCM object, SCM progress, SCM next)
{
SCM i_scm;
SCM_ASSERT_TYPE (gdbscm_is_procedure (next), next, SCM_ARG3, FUNC_NAME,
_("procedure"));
i_scm = itscm_make_iterator_smob (object, progress, next);
return i_scm;
}
/* Return non-zero if SCM is a <gdb:iterator> object. */
int
itscm_is_iterator (SCM scm)
{
return SCM_SMOB_PREDICATE (iterator_smob_tag, scm);
}
/* (iterator? object) -> boolean */
static SCM
gdbscm_iterator_p (SCM scm)
{
return scm_from_bool (itscm_is_iterator (scm));
}
/* (end-of-iteration) -> an "end-of-iteration" marker
We rely on this not being used as a data result of an iterator. */
SCM
gdbscm_end_of_iteration (void)
{
return end_of_iteration;
}
/* Return non-zero if OBJ is the end-of-iteration marker. */
int
itscm_is_end_of_iteration (SCM obj)
{
return scm_is_eq (obj, end_of_iteration);
}
/* (end-of-iteration? obj) -> boolean */
static SCM
gdbscm_end_of_iteration_p (SCM obj)
{
return scm_from_bool (itscm_is_end_of_iteration (obj));
}
/* Call the next! method on ITER, which must be a <gdb:iterator> object.
Returns a <gdb:exception> object if an exception is thrown.
OK_EXCPS is passed to gdbscm_safe_call_1. */
SCM
itscm_safe_call_next_x (SCM iter, excp_matcher_func *ok_excps)
{
iterator_smob *i_smob;
gdb_assert (itscm_is_iterator (iter));
i_smob = (iterator_smob *) SCM_SMOB_DATA (iter);
return gdbscm_safe_call_1 (i_smob->next_x, iter, ok_excps);
}
/* Iterator methods. */
/* Returns the <gdb:iterator> smob in SELF.
Throws an exception if SELF is not an iterator smob. */
SCM
itscm_get_iterator_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (itscm_is_iterator (self), self, arg_pos, func_name,
iterator_smob_name);
return self;
}
/* (iterator-object <gdb:iterator>) -> object */
static SCM
gdbscm_iterator_object (SCM self)
{
SCM i_scm;
iterator_smob *i_smob;
i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
return i_smob->object;
}
/* (iterator-progress <gdb:iterator>) -> object */
static SCM
gdbscm_iterator_progress (SCM self)
{
SCM i_scm;
iterator_smob *i_smob;
i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
return i_smob->progress;
}
/* (set-iterator-progress! <gdb:iterator> object) -> unspecified */
static SCM
gdbscm_set_iterator_progress_x (SCM self, SCM value)
{
SCM i_scm;
iterator_smob *i_smob;
i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
i_smob->progress = value;
return SCM_UNSPECIFIED;
}
/* (iterator-next! <gdb:iterator>) -> object
The result is the next value in the iteration or some "end" marker.
It is up to each iterator's next! function to specify what its end
marker is. */
static SCM
gdbscm_iterator_next_x (SCM self)
{
SCM i_scm;
iterator_smob *i_smob;
i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
/* We leave type-checking of the procedure to gdbscm_safe_call_1. */
return gdbscm_safe_call_1 (i_smob->next_x, self, NULL);
}
/* Initialize the Scheme iterator code. */
static const scheme_function iterator_functions[] =
{
{ "make-iterator", 3, 0, 0, gdbscm_make_iterator,
"\
Create a <gdb:iterator> object.\n\
\n\
Arguments: object progress next!\n\
object: The object to iterate over.\n\
progress: An object to use to track progress of the iteration.\n\
next!: A procedure of one argument, the iterator.\n\
Returns the next element in the iteration or an implementation-chosen\n\
value to signify iteration is complete.\n\
By convention end-of-iteration should be marked with (end-of-iteration)\n\
from module (gdb iterator)." },
{ "iterator?", 1, 0, 0, gdbscm_iterator_p,
"\
Return #t if the object is a <gdb:iterator> object." },
{ "iterator-object", 1, 0, 0, gdbscm_iterator_object,
"\
Return the object being iterated over." },
{ "iterator-progress", 1, 0, 0, gdbscm_iterator_progress,
"\
Return the progress object of the iterator." },
{ "set-iterator-progress!", 2, 0, 0, gdbscm_set_iterator_progress_x,
"\
Set the progress object of the iterator." },
{ "iterator-next!", 1, 0, 0, gdbscm_iterator_next_x,
"\
Invoke the next! procedure of the iterator and return its result." },
{ "end-of-iteration", 0, 0, 0, gdbscm_end_of_iteration,
"\
Return the end-of-iteration marker." },
{ "end-of-iteration?", 1, 0, 0, gdbscm_end_of_iteration_p,
"\
Return #t if the object is the end-of-iteration marker." },
END_FUNCTIONS
};
void
gdbscm_initialize_iterators (void)
{
iterator_smob_tag = gdbscm_make_smob_type (iterator_smob_name,
sizeof (iterator_smob));
scm_set_smob_mark (iterator_smob_tag, itscm_mark_iterator_smob);
scm_set_smob_print (iterator_smob_tag, itscm_print_iterator_smob);
gdbscm_define_functions (iterator_functions, 1);
/* We can make this more unique if it's necessary,
but this is good enough for now. */
end_of_iteration = scm_from_latin1_keyword ("end-of-iteration");
}

373
gdb/guile/scm-lazy-string.c Normal file
View File

@ -0,0 +1,373 @@
/* Scheme interface to lazy strings.
Copyright (C) 2010-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 "charset.h"
#include "value.h"
#include "exceptions.h"
#include "valprint.h"
#include "language.h"
#include "gdb_assert.h"
#include "guile-internal.h"
/* The <gdb:lazy-string> smob. */
typedef struct
{
/* This always appears first. */
gdb_smob base;
/* Holds the address of the lazy string. */
CORE_ADDR address;
/* Holds the encoding that will be applied to the string when the string
is printed by GDB. If the encoding is set to NULL then GDB will select
the most appropriate encoding when the sting is printed.
Space for this is malloc'd and will be freed when the object is
freed. */
char *encoding;
/* Holds the length of the string in characters. If the length is -1,
then the string will be fetched and encoded up to the first null of
appropriate width. */
int length;
/* This attribute holds the type that is represented by the lazy
string's type. */
struct type *type;
} lazy_string_smob;
static const char lazy_string_smob_name[] = "gdb:lazy-string";
/* The tag Guile knows the lazy string smob by. */
static scm_t_bits lazy_string_smob_tag;
/* Administrivia for lazy string smobs. */
/* The smob "mark" function for <gdb:lazy-string>. */
static SCM
lsscm_mark_lazy_string_smob (SCM self)
{
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
/* Do this last. */
return gdbscm_mark_gsmob (&ls_smob->base);
}
/* The smob "free" function for <gdb:lazy-string>. */
static size_t
lsscm_free_lazy_string_smob (SCM self)
{
lazy_string_smob *v_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
xfree (v_smob->encoding);
return 0;
}
/* The smob "print" function for <gdb:lazy-string>. */
static int
lsscm_print_lazy_string_smob (SCM self, SCM port, scm_print_state *pstate)
{
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s", lazy_string_smob_name);
gdbscm_printf (port, " @%s", hex_string (ls_smob->address));
if (ls_smob->length >= 0)
gdbscm_printf (port, " length %d", ls_smob->length);
if (ls_smob->encoding != NULL)
gdbscm_printf (port, " encoding %s", ls_smob->encoding);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* Low level routine to create a <gdb:lazy-string> object.
The caller must verify !(address == 0 && length != 0). */
static SCM
lsscm_make_lazy_string_smob (CORE_ADDR address, int length,
const char *encoding, struct type *type)
{
lazy_string_smob *ls_smob = (lazy_string_smob *)
scm_gc_malloc (sizeof (lazy_string_smob), lazy_string_smob_name);
SCM ls_scm;
/* Caller must verify this. */
gdb_assert (!(address == 0 && length != 0));
gdb_assert (type != NULL);
ls_smob->address = address;
/* Coerce all values < 0 to -1. */
ls_smob->length = length < 0 ? -1 : length;
if (encoding == NULL || strcmp (encoding, "") == 0)
ls_smob->encoding = NULL;
else
ls_smob->encoding = xstrdup (encoding);
ls_smob->type = type;
ls_scm = scm_new_smob (lazy_string_smob_tag, (scm_t_bits) ls_smob);
gdbscm_init_gsmob (&ls_smob->base);
return ls_scm;
}
/* Return non-zero if SCM is a <gdb:lazy-string> object. */
int
lsscm_is_lazy_string (SCM scm)
{
return SCM_SMOB_PREDICATE (lazy_string_smob_tag, scm);
}
/* (lazy-string? object) -> boolean */
static SCM
gdbscm_lazy_string_p (SCM scm)
{
return scm_from_bool (lsscm_is_lazy_string (scm));
}
/* Main entry point to create a <gdb:lazy-string> object.
If there's an error a <gdb:exception> object is returned. */
SCM
lsscm_make_lazy_string (CORE_ADDR address, int length,
const char *encoding, struct type *type)
{
if (address == 0 && length != 0)
{
return gdbscm_make_out_of_range_error
(NULL, 0, scm_from_int (length),
_("cannot create a lazy string with address 0x0"
" and a non-zero length"));
}
if (type == NULL)
{
return gdbscm_make_out_of_range_error
(NULL, 0, scm_from_int (0), _("a lazy string's type cannot be NULL"));
}
return lsscm_make_lazy_string_smob (address, length, encoding, type);
}
/* Returns the <gdb:lazy-string> smob in SELF.
Throws an exception if SELF is not a <gdb:lazy-string> object. */
static SCM
lsscm_get_lazy_string_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (lsscm_is_lazy_string (self), self, arg_pos, func_name,
lazy_string_smob_name);
return self;
}
/* Lazy string methods. */
/* (lazy-string-address <gdb:lazy-string>) -> address */
static SCM
gdbscm_lazy_string_address (SCM self)
{
SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
return gdbscm_scm_from_ulongest (ls_smob->address);
}
/* (lazy-string-length <gdb:lazy-string>) -> integer */
static SCM
gdbscm_lazy_string_length (SCM self)
{
SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
return scm_from_int (ls_smob->length);
}
/* (lazy-string-encoding <gdb:lazy-string>) -> string */
static SCM
gdbscm_lazy_string_encoding (SCM self)
{
SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
/* An encoding can be set to NULL by the user, so check first.
If NULL return #f. */
if (ls_smob != NULL)
return gdbscm_scm_from_c_string (ls_smob->encoding);
return SCM_BOOL_F;
}
/* (lazy-string-type <gdb:lazy-string>) -> <gdb:type> */
static SCM
gdbscm_lazy_string_type (SCM self)
{
SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
return tyscm_scm_from_type (ls_smob->type);
}
/* (lazy-string->value <gdb:lazy-string>) -> <gdb:value> */
static SCM
gdbscm_lazy_string_to_value (SCM self)
{
SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
struct value *value = NULL;
volatile struct gdb_exception except;
if (ls_smob->address == 0)
{
gdbscm_throw (gdbscm_make_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
_("cannot create a value from NULL")));
}
TRY_CATCH (except, RETURN_MASK_ALL)
{
value = value_at_lazy (ls_smob->type, ls_smob->address);
}
GDBSCM_HANDLE_GDB_EXCEPTION (except);
return vlscm_scm_from_value (value);
}
/* A "safe" version of gdbscm_lazy_string_to_value for use by
vlscm_convert_typed_value_from_scheme.
The result, upon success, is the value of <gdb:lazy-string> STRING.
ARG_POS is the argument position of STRING in the original Scheme
function call, used in exception text.
If there's an error, NULL is returned and a <gdb:exception> object
is stored in *except_scmp.
Note: The result is still "lazy". The caller must call value_fetch_lazy
to actually fetch the value. */
struct value *
lsscm_safe_lazy_string_to_value (SCM string, int arg_pos,
const char *func_name, SCM *except_scmp)
{
lazy_string_smob *ls_smob;
struct value *value = NULL;
volatile struct gdb_exception except;
gdb_assert (lsscm_is_lazy_string (string));
ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (string);
*except_scmp = SCM_BOOL_F;
if (ls_smob->address == 0)
{
*except_scmp
= gdbscm_make_out_of_range_error (FUNC_NAME, SCM_ARG1, string,
_("cannot create a value from NULL"));
return NULL;
}
TRY_CATCH (except, RETURN_MASK_ALL)
{
value = value_at_lazy (ls_smob->type, ls_smob->address);
}
if (except.reason < 0)
{
*except_scmp = gdbscm_scm_from_gdb_exception (except);
return NULL;
}
return value;
}
/* Print a lazy string to STREAM using val_print_string.
STRING must be a <gdb:lazy-string> object. */
void
lsscm_val_print_lazy_string (SCM string, struct ui_file *stream,
const struct value_print_options *options)
{
lazy_string_smob *ls_smob;
gdb_assert (lsscm_is_lazy_string (string));
ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (string);
val_print_string (ls_smob->type, ls_smob->encoding,
ls_smob->address, ls_smob->length,
stream, options);
}
/* Initialize the Scheme lazy-strings code. */
static const scheme_function lazy_string_functions[] =
{
{ "lazy-string?", 1, 0, 0, gdbscm_lazy_string_p,
"\
Return #t if the object is a <gdb:lazy-string> object." },
{ "lazy-string-address", 1, 0, 0, gdbscm_lazy_string_address,
"\
Return the address of the lazy-string." },
{ "lazy-string-length", 1, 0, 0, gdbscm_lazy_string_length,
"\
Return the length of the lazy-string.\n\
If the length is -1 then the length is determined by the first null\n\
of appropriate width." },
{ "lazy-string-encoding", 1, 0, 0, gdbscm_lazy_string_encoding,
"\
Return the encoding of the lazy-string." },
{ "lazy-string-type", 1, 0, 0, gdbscm_lazy_string_type,
"\
Return the <gdb:type> of the lazy-string." },
{ "lazy-string->value", 1, 0, 0, gdbscm_lazy_string_to_value,
"\
Return the <gdb:value> representation of the lazy-string." },
END_FUNCTIONS
};
void
gdbscm_initialize_lazy_strings (void)
{
lazy_string_smob_tag = gdbscm_make_smob_type (lazy_string_smob_name,
sizeof (lazy_string_smob));
scm_set_smob_mark (lazy_string_smob_tag, lsscm_mark_lazy_string_smob);
scm_set_smob_free (lazy_string_smob_tag, lsscm_free_lazy_string_smob);
scm_set_smob_print (lazy_string_smob_tag, lsscm_print_lazy_string_smob);
gdbscm_define_functions (lazy_string_functions, 1);
}

998
gdb/guile/scm-math.c Normal file
View File

@ -0,0 +1,998 @@
/* GDB/Scheme support for math operations on values.
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 "arch-utils.h"
#include "charset.h"
#include "cp-abi.h"
#include "doublest.h" /* Needed by dfp.h. */
#include "expression.h" /* Needed by dfp.h. */
#include "dfp.h"
#include "gdb_assert.h"
#include "symtab.h" /* Needed by language.h. */
#include "language.h"
#include "valprint.h"
#include "value.h"
#include "guile-internal.h"
/* Note: Use target types here to remain consistent with the values system in
GDB (which uses target arithmetic). */
enum valscm_unary_opcode
{
VALSCM_NOT,
VALSCM_NEG,
VALSCM_NOP,
VALSCM_ABS,
/* Note: This is Scheme's "logical not", not GDB's.
GDB calls this UNOP_COMPLEMENT. */
VALSCM_LOGNOT
};
enum valscm_binary_opcode
{
VALSCM_ADD,
VALSCM_SUB,
VALSCM_MUL,
VALSCM_DIV,
VALSCM_REM,
VALSCM_MOD,
VALSCM_POW,
VALSCM_LSH,
VALSCM_RSH,
VALSCM_MIN,
VALSCM_MAX,
VALSCM_BITAND,
VALSCM_BITOR,
VALSCM_BITXOR
};
/* If TYPE is a reference, return the target; otherwise return TYPE. */
#define STRIP_REFERENCE(TYPE) \
((TYPE_CODE (TYPE) == TYPE_CODE_REF) ? (TYPE_TARGET_TYPE (TYPE)) : (TYPE))
/* Returns a value object which is the result of applying the operation
specified by OPCODE to the given argument.
If there's an error a Scheme exception is thrown. */
static SCM
vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name)
{
struct gdbarch *gdbarch = get_current_arch ();
const struct language_defn *language = current_language;
struct value *arg1;
SCM result = SCM_BOOL_F;
struct value *res_val = NULL;
SCM except_scm;
struct cleanup *cleanups;
volatile struct gdb_exception except;
cleanups = make_cleanup_value_free_to_mark (value_mark ());
arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
&except_scm, gdbarch, language);
if (arg1 == NULL)
{
do_cleanups (cleanups);
gdbscm_throw (except_scm);
}
TRY_CATCH (except, RETURN_MASK_ALL)
{
switch (opcode)
{
case VALSCM_NOT:
/* Alas gdb and guile use the opposite meaning for "logical not". */
{
struct type *type = language_bool_type (language, gdbarch);
res_val
= value_from_longest (type, (LONGEST) value_logical_not (arg1));
}
break;
case VALSCM_NEG:
res_val = value_neg (arg1);
break;
case VALSCM_NOP:
/* Seemingly a no-op, but if X was a Scheme value it is now
a <gdb:value> object. */
res_val = arg1;
break;
case VALSCM_ABS:
if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
res_val = value_neg (arg1);
else
res_val = arg1;
break;
case VALSCM_LOGNOT:
res_val = value_complement (arg1);
break;
default:
gdb_assert_not_reached ("unsupported operation");
}
}
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
gdb_assert (res_val != NULL);
result = vlscm_scm_from_value (res_val);
do_cleanups (cleanups);
if (gdbscm_is_exception (result))
gdbscm_throw (result);
return result;
}
/* Returns a value object which is the result of applying the operation
specified by OPCODE to the given arguments.
If there's an error a Scheme exception is thrown. */
static SCM
vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y,
const char *func_name)
{
struct gdbarch *gdbarch = get_current_arch ();
const struct language_defn *language = current_language;
struct value *arg1, *arg2;
SCM result = SCM_BOOL_F;
struct value *res_val = NULL;
SCM except_scm;
struct cleanup *cleanups;
volatile struct gdb_exception except;
cleanups = make_cleanup_value_free_to_mark (value_mark ());
arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
&except_scm, gdbarch, language);
if (arg1 == NULL)
{
do_cleanups (cleanups);
gdbscm_throw (except_scm);
}
arg2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
&except_scm, gdbarch, language);
if (arg2 == NULL)
{
do_cleanups (cleanups);
gdbscm_throw (except_scm);
}
TRY_CATCH (except, RETURN_MASK_ALL)
{
switch (opcode)
{
case VALSCM_ADD:
{
struct type *ltype = value_type (arg1);
struct type *rtype = value_type (arg2);
CHECK_TYPEDEF (ltype);
ltype = STRIP_REFERENCE (ltype);
CHECK_TYPEDEF (rtype);
rtype = STRIP_REFERENCE (rtype);
if (TYPE_CODE (ltype) == TYPE_CODE_PTR
&& is_integral_type (rtype))
res_val = value_ptradd (arg1, value_as_long (arg2));
else if (TYPE_CODE (rtype) == TYPE_CODE_PTR
&& is_integral_type (ltype))
res_val = value_ptradd (arg2, value_as_long (arg1));
else
res_val = value_binop (arg1, arg2, BINOP_ADD);
}
break;
case VALSCM_SUB:
{
struct type *ltype = value_type (arg1);
struct type *rtype = value_type (arg2);
CHECK_TYPEDEF (ltype);
ltype = STRIP_REFERENCE (ltype);
CHECK_TYPEDEF (rtype);
rtype = STRIP_REFERENCE (rtype);
if (TYPE_CODE (ltype) == TYPE_CODE_PTR
&& TYPE_CODE (rtype) == TYPE_CODE_PTR)
{
/* A ptrdiff_t for the target would be preferable here. */
res_val
= value_from_longest (builtin_type (gdbarch)->builtin_long,
value_ptrdiff (arg1, arg2));
}
else if (TYPE_CODE (ltype) == TYPE_CODE_PTR
&& is_integral_type (rtype))
res_val = value_ptradd (arg1, - value_as_long (arg2));
else
res_val = value_binop (arg1, arg2, BINOP_SUB);
}
break;
case VALSCM_MUL:
res_val = value_binop (arg1, arg2, BINOP_MUL);
break;
case VALSCM_DIV:
res_val = value_binop (arg1, arg2, BINOP_DIV);
break;
case VALSCM_REM:
res_val = value_binop (arg1, arg2, BINOP_REM);
break;
case VALSCM_MOD:
res_val = value_binop (arg1, arg2, BINOP_MOD);
break;
case VALSCM_POW:
res_val = value_binop (arg1, arg2, BINOP_EXP);
break;
case VALSCM_LSH:
res_val = value_binop (arg1, arg2, BINOP_LSH);
break;
case VALSCM_RSH:
res_val = value_binop (arg1, arg2, BINOP_RSH);
break;
case VALSCM_MIN:
res_val = value_binop (arg1, arg2, BINOP_MIN);
break;
case VALSCM_MAX:
res_val = value_binop (arg1, arg2, BINOP_MAX);
break;
case VALSCM_BITAND:
res_val = value_binop (arg1, arg2, BINOP_BITWISE_AND);
break;
case VALSCM_BITOR:
res_val = value_binop (arg1, arg2, BINOP_BITWISE_IOR);
break;
case VALSCM_BITXOR:
res_val = value_binop (arg1, arg2, BINOP_BITWISE_XOR);
break;
default:
gdb_assert_not_reached ("unsupported operation");
}
}
GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
gdb_assert (res_val != NULL);
result = vlscm_scm_from_value (res_val);
do_cleanups (cleanups);
if (gdbscm_is_exception (result))
gdbscm_throw (result);
return result;
}
/* (value-add x y) -> <gdb:value> */
static SCM
gdbscm_value_add (SCM x, SCM y)
{
return vlscm_binop (VALSCM_ADD, x, y, FUNC_NAME);
}
/* (value-sub x y) -> <gdb:value> */
static SCM
gdbscm_value_sub (SCM x, SCM y)
{
return vlscm_binop (VALSCM_SUB, x, y, FUNC_NAME);
}
/* (value-mul x y) -> <gdb:value> */
static SCM
gdbscm_value_mul (SCM x, SCM y)
{
return vlscm_binop (VALSCM_MUL, x, y, FUNC_NAME);
}
/* (value-div x y) -> <gdb:value> */
static SCM
gdbscm_value_div (SCM x, SCM y)
{
return vlscm_binop (VALSCM_DIV, x, y, FUNC_NAME);
}
/* (value-rem x y) -> <gdb:value> */
static SCM
gdbscm_value_rem (SCM x, SCM y)
{
return vlscm_binop (VALSCM_REM, x, y, FUNC_NAME);
}
/* (value-mod x y) -> <gdb:value> */
static SCM
gdbscm_value_mod (SCM x, SCM y)
{
return vlscm_binop (VALSCM_MOD, x, y, FUNC_NAME);
}
/* (value-pow x y) -> <gdb:value> */
static SCM
gdbscm_value_pow (SCM x, SCM y)
{
return vlscm_binop (VALSCM_POW, x, y, FUNC_NAME);
}
/* (value-neg x) -> <gdb:value> */
static SCM
gdbscm_value_neg (SCM x)
{
return vlscm_unop (VALSCM_NEG, x, FUNC_NAME);
}
/* (value-pos x) -> <gdb:value> */
static SCM
gdbscm_value_pos (SCM x)
{
return vlscm_unop (VALSCM_NOP, x, FUNC_NAME);
}
/* (value-abs x) -> <gdb:value> */
static SCM
gdbscm_value_abs (SCM x)
{
return vlscm_unop (VALSCM_ABS, x, FUNC_NAME);
}
/* (value-lsh x y) -> <gdb:value> */
static SCM
gdbscm_value_lsh (SCM x, SCM y)
{
return vlscm_binop (VALSCM_LSH, x, y, FUNC_NAME);
}
/* (value-rsh x y) -> <gdb:value> */
static SCM
gdbscm_value_rsh (SCM x, SCM y)
{
return vlscm_binop (VALSCM_RSH, x, y, FUNC_NAME);
}
/* (value-min x y) -> <gdb:value> */
static SCM
gdbscm_value_min (SCM x, SCM y)
{
return vlscm_binop (VALSCM_MIN, x, y, FUNC_NAME);
}
/* (value-max x y) -> <gdb:value> */
static SCM
gdbscm_value_max (SCM x, SCM y)
{
return vlscm_binop (VALSCM_MAX, x, y, FUNC_NAME);
}
/* (value-not x) -> <gdb:value> */
static SCM
gdbscm_value_not (SCM x)
{
return vlscm_unop (VALSCM_NOT, x, FUNC_NAME);
}
/* (value-lognot x) -> <gdb:value> */
static SCM
gdbscm_value_lognot (SCM x)
{
return vlscm_unop (VALSCM_LOGNOT, x, FUNC_NAME);
}
/* (value-logand x y) -> <gdb:value> */
static SCM
gdbscm_value_logand (SCM x, SCM y)
{
return vlscm_binop (VALSCM_BITAND, x, y, FUNC_NAME);
}
/* (value-logior x y) -> <gdb:value> */
static SCM
gdbscm_value_logior (SCM x, SCM y)
{
return vlscm_binop (VALSCM_BITOR, x, y, FUNC_NAME);
}
/* (value-logxor x y) -> <gdb:value> */
static SCM
gdbscm_value_logxor (SCM x, SCM y)
{
return vlscm_binop (VALSCM_BITXOR, x, y, FUNC_NAME);
}
/* Utility to perform all value comparisons.
If there's an error a Scheme exception is thrown. */
static SCM
vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name)
{
struct gdbarch *gdbarch = get_current_arch ();
const struct language_defn *language = current_language;
struct value *v1, *v2;
int result = 0;
SCM except_scm;
struct cleanup *cleanups;
volatile struct gdb_exception except;
cleanups = make_cleanup_value_free_to_mark (value_mark ());
v1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
&except_scm, gdbarch, language);
if (v1 == NULL)
{
do_cleanups (cleanups);
gdbscm_throw (except_scm);
}
v2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
&except_scm, gdbarch, language);
if (v2 == NULL)
{
do_cleanups (cleanups);
gdbscm_throw (except_scm);
}
TRY_CATCH (except, RETURN_MASK_ALL)
{
switch (op)
{
case BINOP_LESS:
result = value_less (v1, v2);
break;
case BINOP_LEQ:
result = (value_less (v1, v2)
|| value_equal (v1, v2));
break;
case BINOP_EQUAL:
result = value_equal (v1, v2);
break;
case BINOP_NOTEQUAL:
gdb_assert_not_reached ("not-equal not implemented");
case BINOP_GTR:
result = value_less (v2, v1);
break;
case BINOP_GEQ:
result = (value_less (v2, v1)
|| value_equal (v1, v2));
break;
default:
gdb_assert_not_reached ("invalid <gdb:value> comparison");
}
}
do_cleanups (cleanups);
GDBSCM_HANDLE_GDB_EXCEPTION (except);
return scm_from_bool (result);
}
/* (value=? x y) -> boolean
There is no "not-equal?" function (value!= ?) on purpose.
We're following string=?, etc. as our Guide here. */
static SCM
gdbscm_value_eq_p (SCM x, SCM y)
{
return vlscm_rich_compare (BINOP_EQUAL, x, y, FUNC_NAME);
}
/* (value<? x y) -> boolean */
static SCM
gdbscm_value_lt_p (SCM x, SCM y)
{
return vlscm_rich_compare (BINOP_LESS, x, y, FUNC_NAME);
}
/* (value<=? x y) -> boolean */
static SCM
gdbscm_value_le_p (SCM x, SCM y)
{
return vlscm_rich_compare (BINOP_LEQ, x, y, FUNC_NAME);
}
/* (value>? x y) -> boolean */
static SCM
gdbscm_value_gt_p (SCM x, SCM y)
{
return vlscm_rich_compare (BINOP_GTR, x, y, FUNC_NAME);
}
/* (value>=? x y) -> boolean */
static SCM
gdbscm_value_ge_p (SCM x, SCM y)
{
return vlscm_rich_compare (BINOP_GEQ, x, y, FUNC_NAME);
}
/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
Convert OBJ, a Scheme number, to a <gdb:value> object.
OBJ_ARG_POS is its position in the argument list, used in exception text.
TYPE is the result type. TYPE_ARG_POS is its position in
the argument list, used in exception text.
TYPE_SCM is Scheme object wrapping TYPE, used in exception text.
If the number isn't representable, e.g. it's too big, a <gdb:exception>
object is stored in *EXCEPT_SCMP and NULL is returned.
The conversion may throw a gdb error, e.g., if TYPE is invalid. */
static struct value *
vlscm_convert_typed_number (const char *func_name, int obj_arg_pos, SCM obj,
int type_arg_pos, SCM type_scm, struct type *type,
struct gdbarch *gdbarch, SCM *except_scmp)
{
if (is_integral_type (type)
|| TYPE_CODE (type) == TYPE_CODE_PTR)
{
if (TYPE_UNSIGNED (type))
{
ULONGEST max;
get_unsigned_type_max (type, &max);
if (!scm_is_unsigned_integer (obj, 0, max))
{
*except_scmp
= gdbscm_make_out_of_range_error (func_name,
obj_arg_pos, obj,
_("value out of range for type"));
return NULL;
}
return value_from_longest (type, gdbscm_scm_to_ulongest (obj));
}
else
{
LONGEST min, max;
get_signed_type_minmax (type, &min, &max);
if (!scm_is_signed_integer (obj, min, max))
{
*except_scmp
= gdbscm_make_out_of_range_error (func_name,
obj_arg_pos, obj,
_("value out of range for type"));
return NULL;
}
return value_from_longest (type, gdbscm_scm_to_longest (obj));
}
}
else if (TYPE_CODE (type) == TYPE_CODE_FLT)
return value_from_double (type, scm_to_double (obj));
else
{
*except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
NULL);
return NULL;
}
}
/* Return non-zero if OBJ, an integer, fits in TYPE. */
static int
vlscm_integer_fits_p (SCM obj, struct type *type)
{
if (TYPE_UNSIGNED (type))
{
ULONGEST max;
/* If scm_is_unsigned_integer can't work with this type, just punt. */
if (TYPE_LENGTH (type) > sizeof (scm_t_uintmax))
return 0;
get_unsigned_type_max (type, &max);
return scm_is_unsigned_integer (obj, 0, max);
}
else
{
LONGEST min, max;
/* If scm_is_signed_integer can't work with this type, just punt. */
if (TYPE_LENGTH (type) > sizeof (scm_t_intmax))
return 0;
get_signed_type_minmax (type, &min, &max);
return scm_is_signed_integer (obj, min, max);
}
}
/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
Convert OBJ, a Scheme number, to a <gdb:value> object.
OBJ_ARG_POS is its position in the argument list, used in exception text.
If OBJ is an integer, then the smallest int that will hold the value in
the following progression is chosen:
int, unsigned int, long, unsigned long, long long, unsigned long long.
Otherwise, if OBJ is a real number, then it is converted to a double.
Otherwise an exception is thrown.
If the number isn't representable, e.g. it's too big, a <gdb:exception>
object is stored in *EXCEPT_SCMP and NULL is returned. */
static struct value *
vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj,
struct gdbarch *gdbarch, SCM *except_scmp)
{
const struct builtin_type *bt = builtin_type (gdbarch);
/* One thing to keep in mind here is that we are interested in the
target's representation of OBJ, not the host's. */
if (scm_is_exact (obj) && scm_is_integer (obj))
{
if (vlscm_integer_fits_p (obj, bt->builtin_int))
return value_from_longest (bt->builtin_int,
gdbscm_scm_to_longest (obj));
if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int))
return value_from_longest (bt->builtin_unsigned_int,
gdbscm_scm_to_ulongest (obj));
if (vlscm_integer_fits_p (obj, bt->builtin_long))
return value_from_longest (bt->builtin_long,
gdbscm_scm_to_longest (obj));
if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long))
return value_from_longest (bt->builtin_unsigned_long,
gdbscm_scm_to_ulongest (obj));
if (vlscm_integer_fits_p (obj, bt->builtin_long_long))
return value_from_longest (bt->builtin_long_long,
gdbscm_scm_to_longest (obj));
if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long))
return value_from_longest (bt->builtin_unsigned_long_long,
gdbscm_scm_to_ulongest (obj));
}
else if (scm_is_real (obj))
return value_from_double (bt->builtin_double, scm_to_double (obj));
*except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj,
_("value not a number representable on the target"));
return NULL;
}
/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
Convert BV, a Scheme bytevector, to a <gdb:value> object.
TYPE, if non-NULL, is the result type. Otherwise, a vector of type
uint8_t is used.
TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
or #f if TYPE is NULL.
If the bytevector isn't the same size as the type, then a <gdb:exception>
object is stored in *EXCEPT_SCMP, and NULL is returned. */
static struct value *
vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm,
int arg_pos, const char *func_name,
SCM *except_scmp, struct gdbarch *gdbarch)
{
LONGEST length = SCM_BYTEVECTOR_LENGTH (bv);
struct value *value;
if (type == NULL)
{
type = builtin_type (gdbarch)->builtin_uint8;
type = lookup_array_range_type (type, 0, length);
make_vector_type (type);
}
type = check_typedef (type);
if (TYPE_LENGTH (type) != length)
{
*except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos,
type_scm,
_("size of type does not match size of bytevector"));
return NULL;
}
value = value_from_contents (type,
(gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv));
return value;
}
/* Convert OBJ, a Scheme value, to a <gdb:value> object.
OBJ_ARG_POS is its position in the argument list, used in exception text.
TYPE, if non-NULL, is the result type which must be compatible with
the value being converted.
If TYPE is NULL then a suitable default type is chosen.
TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
or SCM_UNDEFINED if TYPE is NULL.
TYPE_ARG_POS is its position in the argument list, used in exception text,
or -1 if TYPE is NULL.
OBJ may also be a <gdb:value> object, in which case a copy is returned
and TYPE must be NULL.
If the value cannot be converted, NULL is returned and a gdb:exception
object is stored in *EXCEPT_SCMP.
Otherwise the new value is returned, added to the all_values chain. */
struct value *
vlscm_convert_typed_value_from_scheme (const char *func_name,
int obj_arg_pos, SCM obj,
int type_arg_pos, SCM type_scm,
struct type *type,
SCM *except_scmp,
struct gdbarch *gdbarch,
const struct language_defn *language)
{
struct value *value = NULL;
SCM except_scm = SCM_BOOL_F;
volatile struct gdb_exception except;
if (type == NULL)
{
gdb_assert (type_arg_pos == -1);
gdb_assert (SCM_UNBNDP (type_scm));
}
*except_scmp = SCM_BOOL_F;
TRY_CATCH (except, RETURN_MASK_ALL)
{
if (vlscm_is_value (obj))
{
if (type != NULL)
{
except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
type_scm,
_("No type allowed"));
value = NULL;
}
else
value = value_copy (vlscm_scm_to_value (obj));
}
else if (gdbscm_is_true (scm_bytevector_p (obj)))
{
value = vlscm_convert_bytevector (obj, type, type_scm,
obj_arg_pos, func_name,
&except_scm, gdbarch);
}
else if (gdbscm_is_bool (obj))
{
if (type != NULL
&& !is_integral_type (type))
{
except_scm = gdbscm_make_type_error (func_name, type_arg_pos,
type_scm, NULL);
}
else
{
value = value_from_longest (type
? type
: language_bool_type (language,
gdbarch),
gdbscm_is_true (obj));
}
}
else if (scm_is_number (obj))
{
if (type != NULL)
{
value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj,
type_arg_pos, type_scm, type,
gdbarch, &except_scm);
}
else
{
value = vlscm_convert_number (func_name, obj_arg_pos, obj,
gdbarch, &except_scm);
}
}
else if (scm_is_string (obj))
{
char *s;
size_t len;
struct cleanup *cleanup;
if (type != NULL)
{
except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
type_scm,
_("No type allowed"));
value = NULL;
}
else
{
/* TODO: Provide option to specify conversion strategy. */
s = gdbscm_scm_to_string (obj, &len,
target_charset (gdbarch),
0 /*non-strict*/,
&except_scm);
if (s != NULL)
{
cleanup = make_cleanup (xfree, s);
value
= value_cstring (s, len,
language_string_char_type (language,
gdbarch));
do_cleanups (cleanup);
}
else
value = NULL;
}
}
else if (lsscm_is_lazy_string (obj))
{
if (type != NULL)
{
except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
type_scm,
_("No type allowed"));
value = NULL;
}
else
{
value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos,
func_name,
&except_scm);
}
}
else /* OBJ isn't anything we support. */
{
except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
NULL);
value = NULL;
}
}
if (except.reason < 0)
except_scm = gdbscm_scm_from_gdb_exception (except);
if (gdbscm_is_true (except_scm))
{
gdb_assert (value == NULL);
*except_scmp = except_scm;
}
return value;
}
/* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there
is no supplied type. See vlscm_convert_typed_value_from_scheme for
details. */
struct value *
vlscm_convert_value_from_scheme (const char *func_name,
int obj_arg_pos, SCM obj,
SCM *except_scmp, struct gdbarch *gdbarch,
const struct language_defn *language)
{
return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj,
-1, SCM_UNDEFINED, NULL,
except_scmp,
gdbarch, language);
}
/* Initialize value math support. */
static const scheme_function math_functions[] =
{
{ "value-add", 2, 0, 0, gdbscm_value_add,
"\
Return a + b." },
{ "value-sub", 2, 0, 0, gdbscm_value_sub,
"\
Return a - b." },
{ "value-mul", 2, 0, 0, gdbscm_value_mul,
"\
Return a * b." },
{ "value-div", 2, 0, 0, gdbscm_value_div,
"\
Return a / b." },
{ "value-rem", 2, 0, 0, gdbscm_value_rem,
"\
Return a % b." },
{ "value-mod", 2, 0, 0, gdbscm_value_mod,
"\
Return a mod b. See Knuth 1.2.4." },
{ "value-pow", 2, 0, 0, gdbscm_value_pow,
"\
Return pow (x, y)." },
{ "value-not", 1, 0, 0, gdbscm_value_not,
"\
Return !a." },
{ "value-neg", 1, 0, 0, gdbscm_value_neg,
"\
Return -a." },
{ "value-pos", 1, 0, 0, gdbscm_value_pos,
"\
Return a." },
{ "value-abs", 1, 0, 0, gdbscm_value_abs,
"\
Return abs (a)." },
{ "value-lsh", 2, 0, 0, gdbscm_value_lsh,
"\
Return a << b." },
{ "value-rsh", 2, 0, 0, gdbscm_value_rsh,
"\
Return a >> b." },
{ "value-min", 2, 0, 0, gdbscm_value_min,
"\
Return min (a, b)." },
{ "value-max", 2, 0, 0, gdbscm_value_max,
"\
Return max (a, b)." },
{ "value-lognot", 1, 0, 0, gdbscm_value_lognot,
"\
Return ~a." },
{ "value-logand", 2, 0, 0, gdbscm_value_logand,
"\
Return a & b." },
{ "value-logior", 2, 0, 0, gdbscm_value_logior,
"\
Return a | b." },
{ "value-logxor", 2, 0, 0, gdbscm_value_logxor,
"\
Return a ^ b." },
{ "value=?", 2, 0, 0, gdbscm_value_eq_p,
"\
Return a == b." },
{ "value<?", 2, 0, 0, gdbscm_value_lt_p,
"\
Return a < b." },
{ "value<=?", 2, 0, 0, gdbscm_value_le_p,
"\
Return a <= b." },
{ "value>?", 2, 0, 0, gdbscm_value_gt_p,
"\
Return a > b." },
{ "value>=?", 2, 0, 0, gdbscm_value_ge_p,
"\
Return a >= b." },
END_FUNCTIONS
};
void
gdbscm_initialize_math (void)
{
gdbscm_define_functions (math_functions, 1);
}

413
gdb/guile/scm-objfile.c Normal file
View File

@ -0,0 +1,413 @@
/* Scheme interface to objfiles.
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 "objfiles.h"
#include "language.h"
#include "guile-internal.h"
/* The <gdb:objfile> smob.
The typedef for this struct is in guile-internal.h. */
struct _objfile_smob
{
/* This always appears first. */
gdb_smob base;
/* The corresponding objfile. */
struct objfile *objfile;
/* The pretty-printer list of functions. */
SCM pretty_printers;
/* The <gdb:objfile> object we are contained in, needed to protect/unprotect
the object since a reference to it comes from non-gc-managed space
(the objfile). */
SCM containing_scm;
};
static const char objfile_smob_name[] = "gdb:objfile";
/* The tag Guile knows the objfile smob by. */
static scm_t_bits objfile_smob_tag;
static const struct objfile_data *ofscm_objfile_data_key;
/* Return the list of pretty-printers registered with O_SMOB. */
SCM
ofscm_objfile_smob_pretty_printers (objfile_smob *o_smob)
{
return o_smob->pretty_printers;
}
/* Administrivia for objfile smobs. */
/* The smob "mark" function for <gdb:objfile>. */
static SCM
ofscm_mark_objfile_smob (SCM self)
{
objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (self);
scm_gc_mark (o_smob->pretty_printers);
/* We don't mark containing_scm here. It is just a backlink to our
container, and is gc'protected until the objfile is deleted. */
/* Do this last. */
return gdbscm_mark_gsmob (&o_smob->base);
}
/* The smob "print" function for <gdb:objfile>. */
static int
ofscm_print_objfile_smob (SCM self, SCM port, scm_print_state *pstate)
{
objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", objfile_smob_name);
gdbscm_printf (port, "%s",
o_smob->objfile != NULL
? objfile_name (o_smob->objfile)
: "{invalid}");
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* Low level routine to create a <gdb:objfile> object.
It's empty in the sense that an OBJFILE still needs to be associated
with it. */
static SCM
ofscm_make_objfile_smob (void)
{
objfile_smob *o_smob = (objfile_smob *)
scm_gc_malloc (sizeof (objfile_smob), objfile_smob_name);
SCM o_scm;
o_smob->objfile = NULL;
o_smob->pretty_printers = SCM_EOL;
o_scm = scm_new_smob (objfile_smob_tag, (scm_t_bits) o_smob);
o_smob->containing_scm = o_scm;
gdbscm_init_gsmob (&o_smob->base);
return o_scm;
}
/* Clear the OBJFILE pointer in O_SMOB and unprotect the object from GC. */
static void
ofscm_release_objfile (objfile_smob *o_smob)
{
o_smob->objfile = NULL;
scm_gc_unprotect_object (o_smob->containing_scm);
}
/* Objfile registry cleanup handler for when an objfile is deleted. */
static void
ofscm_handle_objfile_deleted (struct objfile *objfile, void *datum)
{
objfile_smob *o_smob = datum;
gdb_assert (o_smob->objfile == objfile);
ofscm_release_objfile (o_smob);
}
/* Return non-zero if SCM is a <gdb:objfile> object. */
static int
ofscm_is_objfile (SCM scm)
{
return SCM_SMOB_PREDICATE (objfile_smob_tag, scm);
}
/* (objfile? object) -> boolean */
static SCM
gdbscm_objfile_p (SCM scm)
{
return scm_from_bool (ofscm_is_objfile (scm));
}
/* Return a pointer to the objfile_smob that encapsulates OBJFILE,
creating one if necessary.
The result is cached so that we have only one copy per objfile. */
objfile_smob *
ofscm_objfile_smob_from_objfile (struct objfile *objfile)
{
objfile_smob *o_smob;
o_smob = objfile_data (objfile, ofscm_objfile_data_key);
if (o_smob == NULL)
{
SCM o_scm = ofscm_make_objfile_smob ();
o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm);
o_smob->objfile = objfile;
set_objfile_data (objfile, ofscm_objfile_data_key, o_smob);
scm_gc_protect_object (o_smob->containing_scm);
}
return o_smob;
}
/* Return the <gdb:objfile> object that encapsulates OBJFILE. */
SCM
ofscm_scm_from_objfile (struct objfile *objfile)
{
objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);
return o_smob->containing_scm;
}
/* Returns the <gdb:objfile> object in SELF.
Throws an exception if SELF is not a <gdb:objfile> object. */
static SCM
ofscm_get_objfile_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (ofscm_is_objfile (self), self, arg_pos, func_name,
objfile_smob_name);
return self;
}
/* Returns a pointer to the objfile smob of SELF.
Throws an exception if SELF is not a <gdb:objfile> object. */
static objfile_smob *
ofscm_get_objfile_smob_arg_unsafe (SCM self, int arg_pos,
const char *func_name)
{
SCM o_scm = ofscm_get_objfile_arg_unsafe (self, arg_pos, func_name);
objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm);
return o_smob;
}
/* Return non-zero if objfile O_SMOB is valid. */
static int
ofscm_is_valid (objfile_smob *o_smob)
{
return o_smob->objfile != NULL;
}
/* Return the objfile smob in SELF, verifying it's valid.
Throws an exception if SELF is not a <gdb:objfile> object or is invalid. */
static objfile_smob *
ofscm_get_valid_objfile_smob_arg_unsafe (SCM self, int arg_pos,
const char *func_name)
{
objfile_smob *o_smob
= ofscm_get_objfile_smob_arg_unsafe (self, arg_pos, func_name);
if (!ofscm_is_valid (o_smob))
{
gdbscm_invalid_object_error (func_name, arg_pos, self,
_("<gdb:objfile>"));
}
return o_smob;
}
/* Objfile methods. */
/* (objfile-valid? <gdb:objfile>) -> boolean
Returns #t if this object file still exists in GDB. */
static SCM
gdbscm_objfile_valid_p (SCM self)
{
objfile_smob *o_smob
= ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
return scm_from_bool (o_smob->objfile != NULL);
}
/* (objfile-filename <gdb:objfile>) -> string
Returns the objfile's file name.
Throw's an exception if the underlying objfile is invalid. */
static SCM
gdbscm_objfile_filename (SCM self)
{
objfile_smob *o_smob
= ofscm_get_valid_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
return gdbscm_scm_from_c_string (objfile_name (o_smob->objfile));
}
/* (objfile-pretty-printers <gdb:objfile>) -> list
Returns the list of pretty-printers for this objfile. */
static SCM
gdbscm_objfile_pretty_printers (SCM self)
{
objfile_smob *o_smob
= ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
return o_smob->pretty_printers;
}
/* (set-objfile-pretty-printers! <gdb:objfile> list) -> unspecified
Set the pretty-printers for this objfile. */
static SCM
gdbscm_set_objfile_pretty_printers_x (SCM self, SCM printers)
{
objfile_smob *o_smob
= ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
SCM_ARG2, FUNC_NAME, _("list"));
o_smob->pretty_printers = printers;
return SCM_UNSPECIFIED;
}
/* The "current" objfile. This is set when gdb detects that a new
objfile has been loaded. It is only set for the duration of a call to
gdbscm_source_objfile_script; it is NULL at other times. */
static struct objfile *ofscm_current_objfile;
/* Set the current objfile to OBJFILE and then read FILE named FILENAME
as Guile code. This does not throw any errors. If an exception
occurs Guile will print the backtrace.
This is the extension_language_script_ops.objfile_script_sourcer
"method". */
void
gdbscm_source_objfile_script (const struct extension_language_defn *extlang,
struct objfile *objfile, FILE *file,
const char *filename)
{
char *msg;
ofscm_current_objfile = objfile;
msg = gdbscm_safe_source_script (filename);
if (msg != NULL)
{
fprintf_filtered (gdb_stderr, "%s", msg);
xfree (msg);
}
ofscm_current_objfile = NULL;
}
/* (current-objfile) -> <gdb:obfjile>
Return the current objfile, or #f if there isn't one.
Ideally this would be named ofscm_current_objfile, but that name is
taken by the variable recording the current objfile. */
static SCM
gdbscm_get_current_objfile (void)
{
if (ofscm_current_objfile == NULL)
return SCM_BOOL_F;
return ofscm_scm_from_objfile (ofscm_current_objfile);
}
/* (objfiles) -> list
Return a list of all objfiles in the current program space. */
static SCM
gdbscm_objfiles (void)
{
struct objfile *objf;
SCM result;
result = SCM_EOL;
ALL_OBJFILES (objf)
{
SCM item = ofscm_scm_from_objfile (objf);
result = scm_cons (item, result);
}
return scm_reverse_x (result, SCM_EOL);
}
/* Initialize the Scheme objfile support. */
static const scheme_function objfile_functions[] =
{
{ "objfile?", 1, 0, 0, gdbscm_objfile_p,
"\
Return #t if the object is a <gdb:objfile> object." },
{ "objfile-valid?", 1, 0, 0, gdbscm_objfile_valid_p,
"\
Return #t if the objfile is valid (hasn't been deleted from gdb)." },
{ "objfile-filename", 1, 0, 0, gdbscm_objfile_filename,
"\
Return the file name of the objfile." },
{ "objfile-pretty-printers", 1, 0, 0, gdbscm_objfile_pretty_printers,
"\
Return a list of pretty-printers of the objfile." },
{ "set-objfile-pretty-printers!", 2, 0, 0,
gdbscm_set_objfile_pretty_printers_x,
"\
Set the list of pretty-printers of the objfile." },
{ "current-objfile", 0, 0, 0, gdbscm_get_current_objfile,
"\
Return the current objfile if there is one or #f if there isn't one." },
{ "objfiles", 0, 0, 0, gdbscm_objfiles,
"\
Return a list of all objfiles in the current program space." },
END_FUNCTIONS
};
void
gdbscm_initialize_objfiles (void)
{
objfile_smob_tag
= gdbscm_make_smob_type (objfile_smob_name, sizeof (objfile_smob));
scm_set_smob_mark (objfile_smob_tag, ofscm_mark_objfile_smob);
scm_set_smob_print (objfile_smob_tag, ofscm_print_objfile_smob);
gdbscm_define_functions (objfile_functions, 1);
ofscm_objfile_data_key
= register_objfile_data_with_cleanup (NULL, ofscm_handle_objfile_deleted);
}

1372
gdb/guile/scm-ports.c Normal file

File diff suppressed because it is too large Load Diff

1138
gdb/guile/scm-pretty-print.c Normal file

File diff suppressed because it is too large Load Diff

464
gdb/guile/scm-safe-call.c Normal file
View File

@ -0,0 +1,464 @@
/* GDB/Scheme support for safe calls into the Guile interpreter.
Copyright (C) 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 "filenames.h"
#include "gdb_assert.h"
#include "guile-internal.h"
/* Struct to marshall args to scscm_safe_call_body. */
struct c_data
{
void *(*func) (void *);
void *data;
/* An error message or NULL for success. */
void *result;
};
/* Struct to marshall args through gdbscm_with_catch. */
struct with_catch_data
{
scm_t_catch_body func;
void *data;
scm_t_catch_handler unwind_handler;
scm_t_catch_handler pre_unwind_handler;
/* If EXCP_MATCHER is non-NULL, it is an excp_matcher_func function.
If the exception is recognized by it, the exception is recorded as is,
without wrapping it in gdb:with-stack. */
excp_matcher_func *excp_matcher;
SCM stack;
SCM catch_result;
};
/* The "body" argument to scm_i_with_continuation_barrier.
Invoke the user-supplied function. */
static SCM
scscm_safe_call_body (void *d)
{
struct c_data *data = (struct c_data *) d;
data->result = data->func (data->data);
return SCM_UNSPECIFIED;
}
/* A "pre-unwind handler" to scm_c_catch that prints the exception
according to "set guile print-stack". */
static SCM
scscm_printing_pre_unwind_handler (void *data, SCM key, SCM args)
{
SCM stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
gdbscm_print_exception_with_stack (SCM_BOOL_F, stack, key, args);
return SCM_UNSPECIFIED;
}
/* A no-op unwind handler. */
static SCM
scscm_nop_unwind_handler (void *data, SCM key, SCM args)
{
return SCM_UNSPECIFIED;
}
/* The "pre-unwind handler" to scm_c_catch that records the exception
for possible later printing. We do this in the pre-unwind handler because
we want the stack to include point where the exception occurred.
If DATA is non-NULL, it is an excp_matcher_func function.
If the exception is recognized by it, the exception is recorded as is,
without wrapping it in gdb:with-stack. */
static SCM
scscm_recording_pre_unwind_handler (void *datap, SCM key, SCM args)
{
struct with_catch_data *data = datap;
excp_matcher_func *matcher = data->excp_matcher;
if (matcher != NULL && matcher (key))
return SCM_UNSPECIFIED;
/* There's no need to record the whole stack if we're not going to print it.
However, convention is to still print the stack frame in which the
exception occurred, even if we're not going to print a full backtrace.
For now, keep it simple. */
data->stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
/* IWBN if we could return the <gdb:exception> here and skip the unwind
handler, but it doesn't work that way. If we want to return a
<gdb:exception> object from the catch it needs to come from the unwind
handler. So what we do is save the stack for later use by the unwind
handler. */
return SCM_UNSPECIFIED;
}
/* Part two of the recording unwind handler.
Here we take the stack saved from the pre-unwind handler and create
the <gdb:exception> object. */
static SCM
scscm_recording_unwind_handler (void *datap, SCM key, SCM args)
{
struct with_catch_data *data = datap;
/* We need to record the stack in the exception since we're about to
throw and lose the location that got the exception. We do this by
wrapping the exception + stack in a new exception. */
if (gdbscm_is_true (data->stack))
return gdbscm_make_exception_with_stack (key, args, data->stack);
return gdbscm_make_exception (key, args);
}
/* Ugh. :-(
Guile doesn't export scm_i_with_continuation_barrier which is exactly
what we need. To cope, have our own wrapper around scm_c_catch and
pass this as the "body" argument to scm_c_with_continuation_barrier.
Darn darn darn. */
static void *
gdbscm_with_catch (void *data)
{
struct with_catch_data *d = data;
d->catch_result
= scm_c_catch (SCM_BOOL_T,
d->func, d->data,
d->unwind_handler, d,
d->pre_unwind_handler, d);
return NULL;
}
/* A wrapper around scm_with_guile that prints backtraces and exceptions
according to "set guile print-stack".
The result if NULL if no exception occurred, otherwise it is a statically
allocated error message (caller must *not* free). */
void *
gdbscm_with_guile (void *(*func) (void *), void *data)
{
struct c_data c_data;
struct with_catch_data catch_data;
c_data.func = func;
c_data.data = data;
/* Set this now in case an exception is thrown. */
c_data.result = _("Error while executing Scheme code.");
catch_data.func = scscm_safe_call_body;
catch_data.data = &c_data;
catch_data.unwind_handler = scscm_nop_unwind_handler;
catch_data.pre_unwind_handler = scscm_printing_pre_unwind_handler;
catch_data.excp_matcher = NULL;
catch_data.stack = SCM_BOOL_F;
catch_data.catch_result = SCM_UNSPECIFIED;
scm_with_guile (gdbscm_with_catch, &catch_data);
return c_data.result;
}
/* Another wrapper of scm_with_guile for use by the safe call/apply routines
in this file, as well as for general purpose calling other functions safely.
For these we want to record the exception, but leave the possible printing
of it to later. */
SCM
gdbscm_call_guile (SCM (*func) (void *), void *data,
excp_matcher_func *ok_excps)
{
struct with_catch_data catch_data;
catch_data.func = func;
catch_data.data = data;
catch_data.unwind_handler = scscm_recording_unwind_handler;
catch_data.pre_unwind_handler = scscm_recording_pre_unwind_handler;
catch_data.excp_matcher = ok_excps;
catch_data.stack = SCM_BOOL_F;
catch_data.catch_result = SCM_UNSPECIFIED;
#if 0
scm_c_with_continuation_barrier (gdbscm_with_catch, &catch_data);
#else
scm_with_guile (gdbscm_with_catch, &catch_data);
#endif
return catch_data.catch_result;
}
/* Utilities to safely call Scheme code, catching all exceptions, and
preventing continuation capture.
The result is the result of calling the function, or if an exception occurs
then the result is a <gdb:exception> smob, which can be tested for with
gdbscm_is_exception. */
/* Helper for gdbscm_safe_call_0. */
static SCM
scscm_call_0_body (void *argsp)
{
SCM *args = argsp;
return scm_call_0 (args[0]);
}
SCM
gdbscm_safe_call_0 (SCM proc, excp_matcher_func *ok_excps)
{
SCM args[] = { proc };
return gdbscm_call_guile (scscm_call_0_body, args, ok_excps);
}
/* Helper for gdbscm_safe_call_1. */
static SCM
scscm_call_1_body (void *argsp)
{
SCM *args = argsp;
return scm_call_1 (args[0], args[1]);
}
SCM
gdbscm_safe_call_1 (SCM proc, SCM arg0, excp_matcher_func *ok_excps)
{
SCM args[] = { proc, arg0 };
return gdbscm_call_guile (scscm_call_1_body, args, ok_excps);
}
/* Helper for gdbscm_safe_call_2. */
static SCM
scscm_call_2_body (void *argsp)
{
SCM *args = argsp;
return scm_call_2 (args[0], args[1], args[2]);
}
SCM
gdbscm_safe_call_2 (SCM proc, SCM arg0, SCM arg1, excp_matcher_func *ok_excps)
{
SCM args[] = { proc, arg0, arg1 };
return gdbscm_call_guile (scscm_call_2_body, args, ok_excps);
}
/* Helper for gdbscm_safe_call_3. */
static SCM
scscm_call_3_body (void *argsp)
{
SCM *args = argsp;
return scm_call_3 (args[0], args[1], args[2], args[3]);
}
SCM
gdbscm_safe_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3,
excp_matcher_func *ok_excps)
{
SCM args[] = { proc, arg1, arg2, arg3 };
return gdbscm_call_guile (scscm_call_3_body, args, ok_excps);
}
/* Helper for gdbscm_safe_call_4. */
static SCM
scscm_call_4_body (void *argsp)
{
SCM *args = argsp;
return scm_call_4 (args[0], args[1], args[2], args[3], args[4]);
}
SCM
gdbscm_safe_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
excp_matcher_func *ok_excps)
{
SCM args[] = { proc, arg1, arg2, arg3, arg4 };
return gdbscm_call_guile (scscm_call_4_body, args, ok_excps);
}
/* Helper for gdbscm_safe_apply_1. */
static SCM
scscm_apply_1_body (void *argsp)
{
SCM *args = argsp;
return scm_apply_1 (args[0], args[1], args[2]);
}
SCM
gdbscm_safe_apply_1 (SCM proc, SCM arg0, SCM rest, excp_matcher_func *ok_excps)
{
SCM args[] = { proc, arg0, rest };
return gdbscm_call_guile (scscm_apply_1_body, args, ok_excps);
}
/* Utilities to call Scheme code, not catching exceptions, and
not preventing continuation capture.
The result is the result of calling the function.
If an exception occurs then Guile is left to handle the exception,
unwinding the stack as appropriate.
USE THESE WITH CARE.
Typically these are called from functions that implement Scheme procedures,
and we don't want to catch the exception; otherwise it will get printed
twice: once when first caught and once if it ends up being rethrown and the
rethrow reaches the top repl, which will confuse the user.
While these calls just pass the call off to the corresponding Guile
procedure, all such calls are routed through these ones to:
a) provide a place to put hooks or whatnot in if we need to,
b) add "unsafe" to the name to alert the reader. */
SCM
gdbscm_unsafe_call_1 (SCM proc, SCM arg0)
{
return scm_call_1 (proc, arg0);
}
/* Utilities for safely evaluating a Scheme expression string. */
struct eval_scheme_string_data
{
const char *string;
int display_result;
};
/* Wrapper to eval a C string in the Guile interpreter.
This is passed to scm_with_guile. */
static void *
scscm_eval_scheme_string (void *datap)
{
struct eval_scheme_string_data *data = datap;
SCM result = scm_c_eval_string (data->string);
if (data->display_result && !scm_is_eq (result, SCM_UNSPECIFIED))
{
SCM port = scm_current_output_port ();
scm_write (result, port);
scm_newline (port);
}
/* If we get here the eval succeeded. */
return NULL;
}
/* Evaluate EXPR in the Guile interpreter, catching all exceptions
and preventing continuation capture.
The result is NULL if no exception occurred. Otherwise, the exception is
printed according to "set guile print-stack" and the result is an error
message allocated with malloc, caller must free. */
char *
gdbscm_safe_eval_string (const char *string, int display_result)
{
struct eval_scheme_string_data data = { string, display_result };
void *result;
result = gdbscm_with_guile (scscm_eval_scheme_string, (void *) &data);
if (result != NULL)
return xstrdup (result);
return NULL;
}
/* Utilities for safely loading Scheme scripts. */
/* Helper function for gdbscm_safe_source_scheme_script. */
static void *
scscm_source_scheme_script (void *data)
{
const char *filename = data;
/* The Guile docs don't specify what the result is.
Maybe it's SCM_UNSPECIFIED, but the docs should specify that. :-) */
scm_c_primitive_load_path (filename);
/* If we get here the load succeeded. */
return NULL;
}
/* Try to load a script, catching all exceptions,
and preventing continuation capture.
The result is NULL if the load succeeded. Otherwise, the exception is
printed according to "set guile print-stack" and the result is an error
message allocated with malloc, caller must free. */
char *
gdbscm_safe_source_script (const char *filename)
{
/* scm_c_primitive_load_path only looks in %load-path for files with
relative paths. An alternative could be to temporarily add "." to
%load-path, but we don't want %load-path to be searched. At least not
by default. This function is invoked by the "source" GDB command which
already has its own path search support. */
char *abs_filename = NULL;
void *result;
if (!IS_ABSOLUTE_PATH (filename))
{
abs_filename = gdb_realpath (filename);
filename = abs_filename;
}
result = gdbscm_with_guile (scscm_source_scheme_script,
(void *) filename);
xfree (abs_filename);
if (result != NULL)
return xstrdup (result);
return NULL;
}
/* Utility for entering an interactive Guile repl. */
void
gdbscm_enter_repl (void)
{
/* It's unfortunate to have to resort to something like this, but
scm_shell doesn't return. :-( I found this code on guile-user@. */
gdbscm_safe_call_1 (scm_c_public_ref ("system repl repl", "start-repl"),
scm_from_latin1_symbol ("scheme"), NULL);
}

246
gdb/guile/scm-string.c Normal file
View File

@ -0,0 +1,246 @@
/* GDB/Scheme charset interface.
Copyright (C) 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 <stdarg.h>
#include "charset.h"
#include "guile-internal.h"
/* Convert a C (latin1) string to an SCM string.
"latin1" is chosen because Guile won't throw an exception. */
SCM
gdbscm_scm_from_c_string (const char *string)
{
return scm_from_latin1_string (string);
}
/* Convert an SCM string to a C (latin1) string.
"latin1" is chosen because Guile won't throw an exception.
Space for the result is allocated with malloc, caller must free.
It is an error to call this if STRING is not a string. */
char *
gdbscm_scm_to_c_string (SCM string)
{
return scm_to_latin1_string (string);
}
/* Use printf to construct a Scheme string. */
SCM
gdbscm_scm_from_printf (const char *format, ...)
{
va_list args;
char *string;
SCM result;
va_start (args, format);
string = xstrvprintf (format, args);
va_end (args);
result = scm_from_latin1_string (string);
xfree (string);
return result;
}
/* Struct to pass data from gdbscm_scm_to_string to
gdbscm_call_scm_to_stringn. */
struct scm_to_stringn_data
{
SCM string;
size_t *lenp;
const char *charset;
int conversion_kind;
char *result;
};
/* Helper for gdbscm_scm_to_string to call scm_to_stringn
from within scm_c_catch. */
static SCM
gdbscm_call_scm_to_stringn (void *datap)
{
struct scm_to_stringn_data *data = datap;
data->result = scm_to_stringn (data->string, data->lenp, data->charset,
data->conversion_kind);
return SCM_BOOL_F;
}
/* Convert an SCM string to a string in charset CHARSET.
This function is guaranteed to not throw an exception.
If STRICT is non-zero, and there's a conversion error, then a
<gdb:exception> object is stored in *EXCEPT_SCMP, and NULL is returned.
If STRICT is zero, then escape sequences are used for characters that
can't be converted, and EXCEPT_SCMP may be passed as NULL.
Space for the result is allocated with malloc, caller must free.
It is an error to call this if STRING is not a string. */
char *
gdbscm_scm_to_string (SCM string, size_t *lenp,
const char *charset, int strict, SCM *except_scmp)
{
struct scm_to_stringn_data data;
SCM scm_result;
data.string = string;
data.lenp = lenp;
data.charset = charset;
data.conversion_kind = (strict
? SCM_FAILED_CONVERSION_ERROR
: SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
data.result = NULL;
scm_result = gdbscm_call_guile (gdbscm_call_scm_to_stringn, &data, NULL);
if (gdbscm_is_false (scm_result))
{
gdb_assert (data.result != NULL);
return data.result;
}
gdb_assert (gdbscm_is_exception (scm_result));
*except_scmp = scm_result;
return NULL;
}
/* Struct to pass data from gdbscm_scm_from_string to
gdbscm_call_scm_from_stringn. */
struct scm_from_stringn_data
{
const char *string;
size_t len;
const char *charset;
int conversion_kind;
SCM result;
};
/* Helper for gdbscm_scm_from_string to call scm_from_stringn
from within scm_c_catch. */
static SCM
gdbscm_call_scm_from_stringn (void *datap)
{
struct scm_from_stringn_data *data = datap;
data->result = scm_from_stringn (data->string, data->len, data->charset,
data->conversion_kind);
return SCM_BOOL_F;
}
/* Convert STRING to a Scheme string in charset CHARSET.
This function is guaranteed to not throw an exception.
If STRICT is non-zero, and there's a conversion error, then a
<gdb:exception> object is returned.
If STRICT is zero, then question marks are used for characters that
can't be converted (limitation of underlying Guile conversion support). */
SCM
gdbscm_scm_from_string (const char *string, size_t len,
const char *charset, int strict)
{
struct scm_from_stringn_data data;
SCM scm_result;
data.string = string;
data.len = len;
data.charset = charset;
/* The use of SCM_FAILED_CONVERSION_QUESTION_MARK is specified by Guile. */
data.conversion_kind = (strict
? SCM_FAILED_CONVERSION_ERROR
: SCM_FAILED_CONVERSION_QUESTION_MARK);
data.result = SCM_UNDEFINED;
scm_result = gdbscm_call_guile (gdbscm_call_scm_from_stringn, &data, NULL);
if (gdbscm_is_false (scm_result))
{
gdb_assert (!SCM_UNBNDP (data.result));
return data.result;
}
gdb_assert (gdbscm_is_exception (scm_result));
return scm_result;
}
/* Convert an SCM string to a target string.
This function will thrown a conversion error if there's a problem.
Space for the result is allocated with malloc, caller must free.
It is an error to call this if STRING is not a string. */
char *
gdbscm_scm_to_target_string_unsafe (SCM string, size_t *lenp,
struct gdbarch *gdbarch)
{
return scm_to_stringn (string, lenp, target_charset (gdbarch),
SCM_FAILED_CONVERSION_ERROR);
}
/* (string->argv string) -> list
Return list of strings split up according to GDB's argv parsing rules.
This is useful when writing GDB commands in Scheme. */
static SCM
gdbscm_string_to_argv (SCM string_scm)
{
char *string;
char **c_argv;
int i;
SCM result = SCM_EOL;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
string_scm, &string);
if (string == NULL || *string == '\0')
{
xfree (string);
return SCM_EOL;
}
c_argv = gdb_buildargv (string);
for (i = 0; c_argv[i] != NULL; ++i)
result = scm_cons (gdbscm_scm_from_c_string (c_argv[i]), result);
freeargv (c_argv);
xfree (string);
return scm_reverse_x (result, SCM_EOL);
}
/* Initialize the Scheme charset interface to GDB. */
static const scheme_function string_functions[] =
{
{ "string->argv", 1, 0, 0, gdbscm_string_to_argv,
"\
Convert a string to a list of strings split up according to\n\
gdb's argv parsing rules." },
END_FUNCTIONS
};
void
gdbscm_initialize_strings (void)
{
gdbscm_define_functions (string_functions, 1);
}

777
gdb/guile/scm-symbol.c Normal file
View File

@ -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);
}

735
gdb/guile/scm-symtab.c Normal file
View File

@ -0,0 +1,735 @@
/* Scheme interface to symbol tables.
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 "symtab.h"
#include "source.h"
#include "objfiles.h"
#include "block.h"
#include "guile-internal.h"
/* A <gdb:symtab> smob. */
typedef struct
{
/* This always appears first.
eqable_gdb_smob is used so that symtabs are eq?-able.
Also, a symtab object is associated with an objfile. eqable_gdb_smob
lets us track the lifetime of all symtabs associated with an objfile.
When an objfile is deleted we need to invalidate the symtab object. */
eqable_gdb_smob base;
/* The GDB symbol table structure.
If this is NULL the symtab is invalid. This can happen when the
underlying objfile is freed. */
struct symtab *symtab;
} symtab_smob;
/* A <gdb:sal> smob.
A smob describing a gdb symtab-and-line object.
A sal is associated with an objfile. All access must be gated by checking
the validity of symtab_scm.
TODO: Sals are not eq?-able at the moment, or even comparable. */
typedef struct
{
/* This always appears first. */
gdb_smob base;
/* The <gdb:symtab> object of the symtab.
We store this instead of a pointer to the symtab_smob because it's not
clear GC will know the symtab_smob is referenced by us otherwise, and we
need quick access to symtab_smob->symtab to know if this sal is valid. */
SCM symtab_scm;
/* The GDB symbol table and line structure.
This object is ephemeral in GDB, so keep our own copy.
The symtab pointer in this struct is not usable: If the symtab is deleted
this pointer will not be updated. Use symtab_scm instead to determine
if this sal is valid. */
struct symtab_and_line sal;
} sal_smob;
static const char symtab_smob_name[] = "gdb:symtab";
/* "symtab-and-line" is pretty long, and "sal" is short and unique. */
static const char sal_smob_name[] = "gdb:sal";
/* The tags Guile knows the symbol table smobs by. */
static scm_t_bits symtab_smob_tag;
static scm_t_bits sal_smob_tag;
static const struct objfile_data *stscm_objfile_data_key;
/* Administrivia for symtab smobs. */
/* Helper function to hash a symbol_smob. */
static hashval_t
stscm_hash_symtab_smob (const void *p)
{
const symtab_smob *st_smob = p;
return htab_hash_pointer (st_smob->symtab);
}
/* Helper function to compute equality of symtab_smobs. */
static int
stscm_eq_symtab_smob (const void *ap, const void *bp)
{
const symtab_smob *a = ap;
const symtab_smob *b = bp;
return (a->symtab == b->symtab
&& a->symtab != NULL);
}
/* Return the struct symtab pointer -> SCM mapping table.
It is created if necessary. */
static htab_t
stscm_objfile_symtab_map (struct symtab *symtab)
{
struct objfile *objfile = symtab->objfile;
htab_t htab = objfile_data (objfile, stscm_objfile_data_key);
if (htab == NULL)
{
htab = gdbscm_create_eqable_gsmob_ptr_map (stscm_hash_symtab_smob,
stscm_eq_symtab_smob);
set_objfile_data (objfile, stscm_objfile_data_key, htab);
}
return htab;
}
/* The smob "mark" function for <gdb:symtab>. */
static SCM
stscm_mark_symtab_smob (SCM self)
{
symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (self);
/* Do this last. */
return gdbscm_mark_eqable_gsmob (&st_smob->base);
}
/* The smob "free" function for <gdb:symtab>. */
static size_t
stscm_free_symtab_smob (SCM self)
{
symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (self);
if (st_smob->symtab != NULL)
{
htab_t htab = stscm_objfile_symtab_map (st_smob->symtab);
gdbscm_clear_eqable_gsmob_ptr_slot (htab, &st_smob->base);
}
/* Not necessary, done to catch bugs. */
st_smob->symtab = NULL;
return 0;
}
/* The smob "print" function for <gdb:symtab>. */
static int
stscm_print_symtab_smob (SCM self, SCM port, scm_print_state *pstate)
{
symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (self);
gdbscm_printf (port, "#<%s ", symtab_smob_name);
gdbscm_printf (port, "%s",
st_smob->symtab != NULL
? symtab_to_filename_for_display (st_smob->symtab)
: "<invalid>");
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* Low level routine to create a <gdb:symtab> object. */
static SCM
stscm_make_symtab_smob (void)
{
symtab_smob *st_smob = (symtab_smob *)
scm_gc_malloc (sizeof (symtab_smob), symtab_smob_name);
SCM st_scm;
st_smob->symtab = NULL;
st_scm = scm_new_smob (symtab_smob_tag, (scm_t_bits) st_smob);
gdbscm_init_eqable_gsmob (&st_smob->base);
return st_scm;
}
/* Return non-zero if SCM is a symbol table smob. */
static int
stscm_is_symtab (SCM scm)
{
return SCM_SMOB_PREDICATE (symtab_smob_tag, scm);
}
/* (symtab? object) -> boolean */
static SCM
gdbscm_symtab_p (SCM scm)
{
return scm_from_bool (stscm_is_symtab (scm));
}
/* Create a new <gdb:symtab> object that encapsulates SYMTAB. */
SCM
stscm_scm_from_symtab (struct symtab *symtab)
{
htab_t htab;
eqable_gdb_smob **slot;
symtab_smob *st_smob, st_smob_for_lookup;
SCM st_scm;
/* If we've already created a gsmob for this symtab, return it.
This makes symtabs eq?-able. */
htab = stscm_objfile_symtab_map (symtab);
st_smob_for_lookup.symtab = symtab;
slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &st_smob_for_lookup.base);
if (*slot != NULL)
return (*slot)->containing_scm;
st_scm = stscm_make_symtab_smob ();
st_smob = (symtab_smob *) SCM_SMOB_DATA (st_scm);
st_smob->symtab = symtab;
gdbscm_fill_eqable_gsmob_ptr_slot (slot, &st_smob->base, st_scm);
return st_scm;
}
/* Returns the <gdb:symtab> object in SELF.
Throws an exception if SELF is not a <gdb:symtab> object. */
static SCM
stscm_get_symtab_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (stscm_is_symtab (self), self, arg_pos, func_name,
symtab_smob_name);
return self;
}
/* Returns a pointer to the symtab smob of SELF.
Throws an exception if SELF is not a <gdb:symtab> object. */
static symtab_smob *
stscm_get_symtab_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
{
SCM st_scm = stscm_get_symtab_arg_unsafe (self, arg_pos, func_name);
symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (st_scm);
return st_smob;
}
/* Return non-zero if symtab ST_SMOB is valid. */
static int
stscm_is_valid (symtab_smob *st_smob)
{
return st_smob->symtab != NULL;
}
/* Throw a Scheme error if SELF is not a valid symtab smob.
Otherwise return a pointer to the symtab_smob object. */
static symtab_smob *
stscm_get_valid_symtab_smob_arg_unsafe (SCM self, int arg_pos,
const char *func_name)
{
symtab_smob *st_smob
= stscm_get_symtab_smob_arg_unsafe (self, arg_pos, func_name);
if (!stscm_is_valid (st_smob))
{
gdbscm_invalid_object_error (func_name, arg_pos, self,
_("<gdb:symtab>"));
}
return st_smob;
}
/* Helper function for stscm_del_objfile_symtabs to mark the symtab
as invalid. */
static int
stscm_mark_symtab_invalid (void **slot, void *info)
{
symtab_smob *st_smob = (symtab_smob *) *slot;
st_smob->symtab = NULL;
return 1;
}
/* This function is called when an objfile is about to be freed.
Invalidate the symbol table as further actions on the symbol table
would result in bad data. All access to st_smob->symtab should be
gated by stscm_get_valid_symtab_smob_arg_unsafe which will raise an
exception on invalid symbol tables. */
static void
stscm_del_objfile_symtabs (struct objfile *objfile, void *datum)
{
htab_t htab = datum;
if (htab != NULL)
{
htab_traverse_noresize (htab, stscm_mark_symtab_invalid, NULL);
htab_delete (htab);
}
}
/* Symbol table methods. */
/* (symtab-valid? <gdb:symtab>) -> boolean
Returns #t if SELF still exists in GDB. */
static SCM
gdbscm_symtab_valid_p (SCM self)
{
symtab_smob *st_smob
= stscm_get_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
return scm_from_bool (stscm_is_valid (st_smob));
}
/* (symtab-filename <gdb:symtab>) -> string */
static SCM
gdbscm_symtab_filename (SCM self)
{
symtab_smob *st_smob
= stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct symtab *symtab = st_smob->symtab;
return gdbscm_scm_from_c_string (symtab_to_filename_for_display (symtab));
}
/* (symtab-fullname <gdb:symtab>) -> string */
static SCM
gdbscm_symtab_fullname (SCM self)
{
symtab_smob *st_smob
= stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
struct symtab *symtab = st_smob->symtab;
return gdbscm_scm_from_c_string (symtab_to_fullname (symtab));
}
/* (symtab-objfile <gdb:symtab>) -> <gdb:objfile> */
static SCM
gdbscm_symtab_objfile (SCM self)
{
symtab_smob *st_smob
= stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
const struct symtab *symtab = st_smob->symtab;
return ofscm_scm_from_objfile (symtab->objfile);
}
/* (symtab-global-block <gdb:symtab>) -> <gdb:block>
Return the GLOBAL_BLOCK of the underlying symtab. */
static SCM
gdbscm_symtab_global_block (SCM self)
{
symtab_smob *st_smob
= stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
const struct symtab *symtab = st_smob->symtab;
const struct blockvector *blockvector;
const struct block *block;
blockvector = BLOCKVECTOR (symtab);
block = BLOCKVECTOR_BLOCK (blockvector, GLOBAL_BLOCK);
return bkscm_scm_from_block (block, symtab->objfile);
}
/* (symtab-static-block <gdb:symtab>) -> <gdb:block>
Return the STATIC_BLOCK of the underlying symtab. */
static SCM
gdbscm_symtab_static_block (SCM self)
{
symtab_smob *st_smob
= stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
const struct symtab *symtab = st_smob->symtab;
const struct blockvector *blockvector;
const struct block *block;
blockvector = BLOCKVECTOR (symtab);
block = BLOCKVECTOR_BLOCK (blockvector, STATIC_BLOCK);
return bkscm_scm_from_block (block, symtab->objfile);
}
/* Administrivia for sal (symtab-and-line) smobs. */
/* The smob "mark" function for <gdb:sal>. */
static SCM
stscm_mark_sal_smob (SCM self)
{
sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (self);
scm_gc_mark (s_smob->symtab_scm);
/* Do this last. */
return gdbscm_mark_gsmob (&s_smob->base);
}
/* The smob "free" function for <gdb:sal>. */
static size_t
stscm_free_sal_smob (SCM self)
{
sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (self);
/* Not necessary, done to catch bugs. */
s_smob->symtab_scm = SCM_UNDEFINED;
return 0;
}
/* The smob "print" function for <gdb:sal>. */
static int
stscm_print_sal_smob (SCM self, SCM port, scm_print_state *pstate)
{
sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (self);
symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (s_smob->symtab_scm);
gdbscm_printf (port, "#<%s ", symtab_smob_name);
scm_write (s_smob->symtab_scm, port);
if (s_smob->sal.line != 0)
gdbscm_printf (port, " line %d", s_smob->sal.line);
scm_puts (">", port);
scm_remember_upto_here_1 (self);
/* Non-zero means success. */
return 1;
}
/* Low level routine to create a <gdb:sal> object. */
static SCM
stscm_make_sal_smob (void)
{
sal_smob *s_smob
= (sal_smob *) scm_gc_malloc (sizeof (sal_smob), sal_smob_name);
SCM s_scm;
s_smob->symtab_scm = SCM_BOOL_F;
memset (&s_smob->sal, 0, sizeof (s_smob->sal));
s_scm = scm_new_smob (sal_smob_tag, (scm_t_bits) s_smob);
gdbscm_init_gsmob (&s_smob->base);
return s_scm;
}
/* Return non-zero if SCM is a <gdb:sal> object. */
static int
stscm_is_sal (SCM scm)
{
return SCM_SMOB_PREDICATE (sal_smob_tag, scm);
}
/* (sal? object) -> boolean */
static SCM
gdbscm_sal_p (SCM scm)
{
return scm_from_bool (stscm_is_sal (scm));
}
/* Create a new <gdb:sal> object that encapsulates SAL. */
SCM
stscm_scm_from_sal (struct symtab_and_line sal)
{
SCM st_scm, s_scm;
sal_smob *s_smob;
st_scm = SCM_BOOL_F;
if (sal.symtab != NULL)
st_scm = stscm_scm_from_symtab (sal.symtab);
s_scm = stscm_make_sal_smob ();
s_smob = (sal_smob *) SCM_SMOB_DATA (s_scm);
s_smob->symtab_scm = st_scm;
s_smob->sal = sal;
return s_scm;
}
/* Returns the <gdb:sal> object in SELF.
Throws an exception if SELF is not a <gdb:sal> object. */
static SCM
stscm_get_sal_arg (SCM self, int arg_pos, const char *func_name)
{
SCM_ASSERT_TYPE (stscm_is_sal (self), self, arg_pos, func_name,
sal_smob_name);
return self;
}
/* Returns a pointer to the sal smob of SELF.
Throws an exception if SELF is not a <gdb:sal> object. */
static sal_smob *
stscm_get_sal_smob_arg (SCM self, int arg_pos, const char *func_name)
{
SCM s_scm = stscm_get_sal_arg (self, arg_pos, func_name);
sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (s_scm);
return s_smob;
}
/* Return non-zero if the symtab in S_SMOB is valid. */
static int
stscm_sal_is_valid (sal_smob *s_smob)
{
symtab_smob *st_smob;
/* If there's no symtab that's ok, the sal is still valid. */
if (gdbscm_is_false (s_smob->symtab_scm))
return 1;
st_smob = (symtab_smob *) SCM_SMOB_DATA (s_smob->symtab_scm);
return st_smob->symtab != NULL;
}
/* Throw a Scheme error if SELF is not a valid sal smob.
Otherwise return a pointer to the sal_smob object. */
static sal_smob *
stscm_get_valid_sal_smob_arg (SCM self, int arg_pos, const char *func_name)
{
sal_smob *s_smob = stscm_get_sal_smob_arg (self, arg_pos, func_name);
if (!stscm_sal_is_valid (s_smob))
{
gdbscm_invalid_object_error (func_name, arg_pos, self,
_("<gdb:sal>"));
}
return s_smob;
}
/* sal methods */
/* (sal-valid? <gdb:sal>) -> boolean
Returns #t if the symtab for SELF still exists in GDB. */
static SCM
gdbscm_sal_valid_p (SCM self)
{
sal_smob *s_smob = stscm_get_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
return scm_from_bool (stscm_sal_is_valid (s_smob));
}
/* (sal-pc <gdb:sal>) -> address */
static SCM
gdbscm_sal_pc (SCM self)
{
sal_smob *s_smob = stscm_get_valid_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
const struct symtab_and_line *sal = &s_smob->sal;
return gdbscm_scm_from_ulongest (sal->pc);
}
/* (sal-last <gdb:sal>) -> address
Returns #f if no ending address is recorded. */
static SCM
gdbscm_sal_last (SCM self)
{
sal_smob *s_smob = stscm_get_valid_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
const struct symtab_and_line *sal = &s_smob->sal;
if (sal->end > 0)
return gdbscm_scm_from_ulongest (sal->end - 1);
return SCM_BOOL_F;
}
/* (sal-line <gdb:sal>) -> integer
Returns #f if no line number is recorded. */
static SCM
gdbscm_sal_line (SCM self)
{
sal_smob *s_smob = stscm_get_valid_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
const struct symtab_and_line *sal = &s_smob->sal;
if (sal->line > 0)
return scm_from_int (sal->line);
return SCM_BOOL_F;
}
/* (sal-symtab <gdb:sal>) -> <gdb:symtab>
Returns #f if no symtab is recorded. */
static SCM
gdbscm_sal_symtab (SCM self)
{
sal_smob *s_smob = stscm_get_valid_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
const struct symtab_and_line *sal = &s_smob->sal;
return s_smob->symtab_scm;
}
/* (find-pc-line address) -> <gdb:sal> */
static SCM
gdbscm_find_pc_line (SCM pc_scm)
{
ULONGEST pc_ull;
struct symtab_and_line sal;
volatile struct gdb_exception except;
init_sal (&sal); /* -Wall */
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc_ull);
TRY_CATCH (except, RETURN_MASK_ALL)
{
CORE_ADDR pc = (CORE_ADDR) pc_ull;
sal = find_pc_line (pc, 0);
}
GDBSCM_HANDLE_GDB_EXCEPTION (except);
return stscm_scm_from_sal (sal);
}
/* Initialize the Scheme symbol support. */
static const scheme_function symtab_functions[] =
{
{ "symtab?", 1, 0, 0, gdbscm_symtab_p,
"\
Return #t if the object is a <gdb:symtab> object." },
{ "symtab-valid?", 1, 0, 0, gdbscm_symtab_valid_p,
"\
Return #t if the symtab still exists in GDB.\n\
Symtabs are deleted when the corresponding objfile is freed." },
{ "symtab-filename", 1, 0, 0, gdbscm_symtab_filename,
"\
Return the symtab's source file name." },
{ "symtab-fullname", 1, 0, 0, gdbscm_symtab_fullname,
"\
Return the symtab's full source file name." },
{ "symtab-objfile", 1, 0, 0, gdbscm_symtab_objfile,
"\
Return the symtab's objfile." },
{ "symtab-global-block", 1, 0, 0, gdbscm_symtab_global_block,
"\
Return the symtab's global block." },
{ "symtab-static-block", 1, 0, 0, gdbscm_symtab_static_block,
"\
Return the symtab's static block." },
{ "sal?", 1, 0, 0, gdbscm_sal_p,
"\
Return #t if the object is a <gdb:sal> (symtab-and-line) object." },
{ "sal-valid?", 1, 0, 0, gdbscm_sal_valid_p,
"\
Return #t if the symtab for the sal still exists in GDB.\n\
Symtabs are deleted when the corresponding objfile is freed." },
{ "sal-symtab", 1, 0, 0, gdbscm_sal_symtab,
"\
Return the sal's symtab." },
{ "sal-line", 1, 0, 0, gdbscm_sal_line,
"\
Return the sal's line number, or #f if there is none." },
{ "sal-pc", 1, 0, 0, gdbscm_sal_pc,
"\
Return the sal's address." },
{ "sal-last", 1, 0, 0, gdbscm_sal_last,
"\
Return the last address specified by the sal, or #f if there is none." },
{ "find-pc-line", 1, 0, 0, gdbscm_find_pc_line,
"\
Return the sal corresponding to the address, or #f if there isn't one.\n\
\n\
Arguments: address" },
END_FUNCTIONS
};
void
gdbscm_initialize_symtabs (void)
{
symtab_smob_tag
= gdbscm_make_smob_type (symtab_smob_name, sizeof (symtab_smob));
scm_set_smob_mark (symtab_smob_tag, stscm_mark_symtab_smob);
scm_set_smob_free (symtab_smob_tag, stscm_free_symtab_smob);
scm_set_smob_print (symtab_smob_tag, stscm_print_symtab_smob);
sal_smob_tag = gdbscm_make_smob_type (sal_smob_name, sizeof (sal_smob));
scm_set_smob_mark (sal_smob_tag, stscm_mark_sal_smob);
scm_set_smob_free (sal_smob_tag, stscm_free_sal_smob);
scm_set_smob_print (sal_smob_tag, stscm_print_sal_smob);
gdbscm_define_functions (symtab_functions, 1);
/* Register an objfile "free" callback so we can properly
invalidate symbol tables, and symbol table and line data
structures when an object file that is about to be deleted. */
stscm_objfile_data_key
= register_objfile_data_with_cleanup (NULL, stscm_del_objfile_symtabs);
}

1495
gdb/guile/scm-type.c Normal file

File diff suppressed because it is too large Load Diff

585
gdb/guile/scm-utils.c Normal file
View File

@ -0,0 +1,585 @@
/* General utility routines for GDB/Scheme code.
Copyright (C) 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 <stdarg.h>
#include <stdint.h>
#include "gdb_assert.h"
#include "guile-internal.h"
/* Define VARIABLES in the gdb module. */
void
gdbscm_define_variables (const scheme_variable *variables, int public)
{
const scheme_variable *sv;
for (sv = variables; sv->name != NULL; ++sv)
{
scm_c_define (sv->name, sv->value);
if (public)
scm_c_export (sv->name, NULL);
}
}
/* Define FUNCTIONS in the gdb module. */
void
gdbscm_define_functions (const scheme_function *functions, int public)
{
const scheme_function *sf;
for (sf = functions; sf->name != NULL; ++sf)
{
SCM proc = scm_c_define_gsubr (sf->name, sf->required, sf->optional,
sf->rest, sf->func);
scm_set_procedure_property_x (proc, gdbscm_documentation_symbol,
gdbscm_scm_from_c_string (sf->doc_string));
if (public)
scm_c_export (sf->name, NULL);
}
}
/* Define CONSTANTS in the gdb module. */
void
gdbscm_define_integer_constants (const scheme_integer_constant *constants,
int public)
{
const scheme_integer_constant *sc;
for (sc = constants; sc->name != NULL; ++sc)
{
scm_c_define (sc->name, scm_from_int (sc->value));
if (public)
scm_c_export (sc->name, NULL);
}
}
/* scm_printf, alas it doesn't exist. */
void
gdbscm_printf (SCM port, const char *format, ...)
{
va_list args;
char *string;
va_start (args, format);
string = xstrvprintf (format, args);
va_end (args);
scm_puts (string, port);
xfree (string);
}
/* Utility for calling from gdb to "display" an SCM object. */
void
gdbscm_debug_display (SCM obj)
{
SCM port = scm_current_output_port ();
scm_display (obj, port);
scm_newline (port);
scm_force_output (port);
}
/* Utility for calling from gdb to "write" an SCM object. */
void
gdbscm_debug_write (SCM obj)
{
SCM port = scm_current_output_port ();
scm_write (obj, port);
scm_newline (port);
scm_force_output (port);
}
/* Subroutine of gdbscm_parse_function_args to simplify it.
Return the number of keyword arguments. */
static int
count_keywords (const SCM *keywords)
{
int i;
if (keywords == NULL)
return 0;
for (i = 0; keywords[i] != SCM_BOOL_F; ++i)
continue;
return i;
}
/* Subroutine of gdbscm_parse_function_args to simplify it.
Validate an argument format string.
The result is a boolean indicating if "." was seen. */
static int
validate_arg_format (const char *format)
{
const char *p;
int length = strlen (format);
int optional_position = -1;
int keyword_position = -1;
int dot_seen = 0;
gdb_assert (length > 0);
for (p = format; *p != '\0'; ++p)
{
switch (*p)
{
case 's':
case 't':
case 'i':
case 'u':
case 'l':
case 'n':
case 'L':
case 'U':
case 'O':
break;
case '|':
gdb_assert (keyword_position < 0);
gdb_assert (optional_position < 0);
optional_position = p - format;
break;
case '#':
gdb_assert (keyword_position < 0);
keyword_position = p - format;
break;
case '.':
gdb_assert (p[1] == '\0');
dot_seen = 1;
break;
default:
gdb_assert_not_reached ("invalid argument format character");
}
}
return dot_seen;
}
/* Our version of SCM_ASSERT_TYPE that calls gdbscm_make_type_error. */
#define CHECK_TYPE(ok, arg, position, func_name, expected_type) \
do { \
if (!(ok)) \
{ \
return gdbscm_make_type_error ((func_name), (position), (arg), \
(expected_type)); \
} \
} while (0)
/* Subroutine of gdbscm_parse_function_args to simplify it.
Check the type of ARG against FORMAT_CHAR and extract the value.
POSITION is the position of ARG in the argument list.
The result is #f upon success or a <gdb:exception> object. */
static SCM
extract_arg (char format_char, SCM arg, void *argp,
const char *func_name, int position)
{
switch (format_char)
{
case 's':
{
char **arg_ptr = argp;
CHECK_TYPE (gdbscm_is_true (scm_string_p (arg)), arg, position,
func_name, _("string"));
*arg_ptr = gdbscm_scm_to_c_string (arg);
break;
}
case 't':
{
int *arg_ptr = argp;
/* While in Scheme, anything non-#f is "true", we're strict. */
CHECK_TYPE (gdbscm_is_bool (arg), arg, position, func_name,
_("boolean"));
*arg_ptr = gdbscm_is_true (arg);
break;
}
case 'i':
{
int *arg_ptr = argp;
CHECK_TYPE (scm_is_signed_integer (arg, INT_MIN, INT_MAX),
arg, position, func_name, _("int"));
*arg_ptr = scm_to_int (arg);
break;
}
case 'u':
{
int *arg_ptr = argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT_MAX),
arg, position, func_name, _("unsigned int"));
*arg_ptr = scm_to_uint (arg);
break;
}
case 'l':
{
long *arg_ptr = argp;
CHECK_TYPE (scm_is_signed_integer (arg, LONG_MIN, LONG_MAX),
arg, position, func_name, _("long"));
*arg_ptr = scm_to_long (arg);
break;
}
case 'n':
{
unsigned long *arg_ptr = argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, ULONG_MAX),
arg, position, func_name, _("unsigned long"));
*arg_ptr = scm_to_ulong (arg);
break;
}
case 'L':
{
LONGEST *arg_ptr = argp;
CHECK_TYPE (scm_is_signed_integer (arg, INT64_MIN, INT64_MAX),
arg, position, func_name, _("LONGEST"));
*arg_ptr = gdbscm_scm_to_longest (arg);
break;
}
case 'U':
{
ULONGEST *arg_ptr = argp;
CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT64_MAX),
arg, position, func_name, _("ULONGEST"));
*arg_ptr = gdbscm_scm_to_ulongest (arg);
break;
}
case 'O':
{
SCM *arg_ptr = argp;
*arg_ptr = arg;
break;
}
default:
gdb_assert_not_reached ("invalid argument format character");
}
return SCM_BOOL_F;
}
#undef CHECK_TYPE
/* Look up KEYWORD in KEYWORD_LIST.
The result is the index of the keyword in the list or -1 if not found. */
static int
lookup_keyword (const SCM *keyword_list, SCM keyword)
{
int i = 0;
while (keyword_list[i] != SCM_BOOL_F)
{
if (scm_is_eq (keyword_list[i], keyword))
return i;
++i;
}
return -1;
}
/* Utility to parse required, optional, and keyword arguments to Scheme
functions. Modelled on PyArg_ParseTupleAndKeywords, but no attempt is made
at similarity or functionality.
There is no result, if there's an error a Scheme exception is thrown.
Guile provides scm_c_bind_keyword_arguments, and feel free to use it.
This is for times when we want a bit more parsing.
BEGINNING_ARG_POS is the position of the first argument passed to this
routine. It should be one of the SCM_ARGn values. It could be > SCM_ARG1
if the caller chooses not to parse one or more required arguments.
KEYWORDS may be NULL if there are no keywords.
FORMAT:
s - string -> char *, malloc'd
t - boolean (gdb uses "t", for biT?) -> int
i - int
u - unsigned int
l - long
n - unsigned long
L - longest
U - unsigned longest
O - random scheme object
| - indicates the next set is for optional arguments
# - indicates the next set is for keyword arguments (must follow |)
. - indicates "rest" arguments are present, this character must appear last
FORMAT must match the definition from scm_c_{make,define}_gsubr.
Required and optional arguments appear in order in the format string.
Afterwards, keyword-based arguments are processed. There must be as many
remaining characters in the format string as their are keywords.
Except for "|#.", the number of characters in the format string must match
#required + #optional + #keywords.
The function is required to be defined in a compatible manner:
#required-args and #optional-arguments must match, and rest-arguments
must be specified if keyword args are desired, and/or regular "rest" args.
Example: For this function,
scm_c_define_gsubr ("execute", 2, 3, 1, foo);
the format string + keyword list could be any of:
1) "ss|ttt#tt", { "key1", "key2", NULL }
2) "ss|ttt.", { NULL }
3) "ss|ttt#t.", { "key1", NULL }
For required and optional args pass the SCM of the argument, and a
pointer to the value to hold the parsed result (type depends on format
char). After that pass the SCM containing the "rest" arguments followed
by pointers to values to hold parsed keyword arguments, and if specified
a pointer to hold the remaining contents of "rest".
For keyword arguments pass two pointers: the first is a pointer to an int
that will contain the position of the argument in the arg list, and the
second will contain result of processing the argument. The int pointed
to by the first value should be initialized to -1. It can then be used
to tell whether the keyword was present.
If both keyword and rest arguments are present, the caller must pass a
pointer to contain the new value of rest (after keyword args have been
removed).
There's currently no way, that I know of, to specify default values for
optional arguments in C-provided functions. At the moment they're a
work-in-progress. The caller should test SCM_UNBNDP for each optional
argument. Unbound optional arguments are ignored. */
void
gdbscm_parse_function_args (const char *func_name,
int beginning_arg_pos,
const SCM *keywords,
const char *format, ...)
{
va_list args;
const char *p;
int i, have_rest, num_keywords, length, position;
int have_optional = 0;
SCM status;
SCM rest = SCM_EOL;
/* Keep track of malloc'd strings. We need to free them upon error. */
VEC (char_ptr) *allocated_strings = NULL;
char *ptr;
have_rest = validate_arg_format (format);
num_keywords = count_keywords (keywords);
va_start (args, format);
p = format;
position = beginning_arg_pos;
/* Process required, optional arguments. */
while (*p && *p != '#' && *p != '.')
{
SCM arg;
void *arg_ptr;
if (*p == '|')
{
have_optional = 1;
++p;
continue;
}
arg = va_arg (args, SCM);
if (!have_optional || !SCM_UNBNDP (arg))
{
arg_ptr = va_arg (args, void *);
status = extract_arg (*p, arg, arg_ptr, func_name, position);
if (!gdbscm_is_false (status))
goto fail;
if (*p == 's')
VEC_safe_push (char_ptr, allocated_strings, *(char **) arg_ptr);
}
++p;
++position;
}
/* Process keyword arguments. */
if (have_rest || num_keywords > 0)
rest = va_arg (args, SCM);
if (num_keywords > 0)
{
SCM *keyword_args = (SCM *) alloca (num_keywords * sizeof (SCM));
int *keyword_positions = (int *) alloca (num_keywords * sizeof (int));
gdb_assert (*p == '#');
++p;
for (i = 0; i < num_keywords; ++i)
{
keyword_args[i] = SCM_UNSPECIFIED;
keyword_positions[i] = -1;
}
while (scm_is_pair (rest)
&& scm_is_keyword (scm_car (rest)))
{
SCM keyword = scm_car (rest);
i = lookup_keyword (keywords, keyword);
if (i < 0)
{
status = gdbscm_make_error (scm_arg_type_key, func_name,
_("Unrecognized keyword: ~a"),
scm_list_1 (keyword), keyword);
goto fail;
}
if (!scm_is_pair (scm_cdr (rest)))
{
status = gdbscm_make_error
(scm_arg_type_key, func_name,
_("Missing value for keyword argument"),
scm_list_1 (keyword), keyword);
goto fail;
}
keyword_args[i] = scm_cadr (rest);
keyword_positions[i] = position + 1;
rest = scm_cddr (rest);
position += 2;
}
for (i = 0; i < num_keywords; ++i)
{
int *arg_pos_ptr = va_arg (args, int *);
void *arg_ptr = va_arg (args, void *);
SCM arg = keyword_args[i];
if (! scm_is_eq (arg, SCM_UNSPECIFIED))
{
*arg_pos_ptr = keyword_positions[i];
status = extract_arg (p[i], arg, arg_ptr, func_name,
keyword_positions[i]);
if (!gdbscm_is_false (status))
goto fail;
if (p[i] == 's')
{
VEC_safe_push (char_ptr, allocated_strings,
*(char **) arg_ptr);
}
}
}
}
/* Process "rest" arguments. */
if (have_rest)
{
if (num_keywords > 0)
{
SCM *rest_ptr = va_arg (args, SCM *);
*rest_ptr = rest;
}
}
else
{
if (! scm_is_null (rest))
{
status = gdbscm_make_error (scm_args_number_key, func_name,
_("Too many arguments"),
SCM_EOL, SCM_BOOL_F);
goto fail;
}
}
va_end (args);
VEC_free (char_ptr, allocated_strings);
return;
fail:
va_end (args);
for (i = 0; VEC_iterate (char_ptr, allocated_strings, i, ptr); ++i)
xfree (ptr);
VEC_free (char_ptr, allocated_strings);
gdbscm_throw (status);
}
/* Return longest L as a scheme object. */
SCM
gdbscm_scm_from_longest (LONGEST l)
{
return scm_from_int64 (l);
}
/* Convert scheme object L to LONGEST.
It is an error to call this if L is not an integer in range of LONGEST.
(because the underlying Scheme function will thrown an exception,
which is not part of our contract with the caller). */
LONGEST
gdbscm_scm_to_longest (SCM l)
{
return scm_to_int64 (l);
}
/* Return unsigned longest L as a scheme object. */
SCM
gdbscm_scm_from_ulongest (ULONGEST l)
{
return scm_from_uint64 (l);
}
/* Convert scheme object U to ULONGEST.
It is an error to call this if U is not an integer in range of ULONGEST
(because the underlying Scheme function will thrown an exception,
which is not part of our contract with the caller). */
ULONGEST
gdbscm_scm_to_ulongest (SCM u)
{
return scm_to_uint64 (u);
}
/* Same as scm_dynwind_free, but uses xfree. */
void
gdbscm_dynwind_xfree (void *ptr)
{
scm_dynwind_unwind_handler (xfree, ptr, SCM_F_WIND_EXPLICITLY);
}
/* Return non-zero if PROC is a procedure. */
int
gdbscm_is_procedure (SCM proc)
{
return gdbscm_is_true (scm_procedure_p (proc));
}

1485
gdb/guile/scm-value.c Normal file

File diff suppressed because it is too large Load Diff

View File

@ -1,3 +1,64 @@
2014-02-10 Doug Evans <xdje42@gmail.com>
* 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.
2014-02-10 Yao Qi <yao@codesourcery.com>
PR testsuite/16543

View File

@ -3448,7 +3448,7 @@ done
ac_config_files="$ac_config_files Makefile gdb.ada/Makefile gdb.arch/Makefile gdb.asm/Makefile gdb.base/Makefile gdb.btrace/Makefile gdb.cell/Makefile gdb.cp/Makefile gdb.disasm/Makefile gdb.dwarf2/Makefile gdb.dlang/Makefile gdb.fortran/Makefile gdb.gdb/Makefile gdb.go/Makefile gdb.server/Makefile gdb.java/Makefile gdb.hp/Makefile gdb.hp/gdb.objdbg/Makefile gdb.hp/gdb.base-hp/Makefile gdb.hp/gdb.aCC/Makefile gdb.hp/gdb.compat/Makefile gdb.hp/gdb.defects/Makefile gdb.linespec/Makefile gdb.mi/Makefile gdb.modula2/Makefile gdb.multi/Makefile gdb.objc/Makefile gdb.opencl/Makefile gdb.opt/Makefile gdb.pascal/Makefile gdb.perf/Makefile gdb.python/Makefile gdb.reverse/Makefile gdb.stabs/Makefile gdb.threads/Makefile gdb.trace/Makefile gdb.xml/Makefile"
ac_config_files="$ac_config_files Makefile gdb.ada/Makefile gdb.arch/Makefile gdb.asm/Makefile gdb.base/Makefile gdb.btrace/Makefile gdb.cell/Makefile gdb.cp/Makefile gdb.disasm/Makefile gdb.dwarf2/Makefile gdb.dlang/Makefile gdb.fortran/Makefile gdb.gdb/Makefile gdb.go/Makefile gdb.server/Makefile gdb.java/Makefile gdb.hp/Makefile gdb.hp/gdb.objdbg/Makefile gdb.hp/gdb.base-hp/Makefile gdb.hp/gdb.aCC/Makefile gdb.hp/gdb.compat/Makefile gdb.hp/gdb.defects/Makefile gdb.guile/Makefile gdb.linespec/Makefile gdb.mi/Makefile gdb.modula2/Makefile gdb.multi/Makefile gdb.objc/Makefile gdb.opencl/Makefile gdb.opt/Makefile gdb.pascal/Makefile gdb.perf/Makefile gdb.python/Makefile gdb.reverse/Makefile gdb.stabs/Makefile gdb.threads/Makefile gdb.trace/Makefile gdb.xml/Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
@ -4170,6 +4170,7 @@ do
"gdb.hp/gdb.aCC/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.hp/gdb.aCC/Makefile" ;;
"gdb.hp/gdb.compat/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.hp/gdb.compat/Makefile" ;;
"gdb.hp/gdb.defects/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.hp/gdb.defects/Makefile" ;;
"gdb.guile/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.guile/Makefile" ;;
"gdb.linespec/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.linespec/Makefile" ;;
"gdb.mi/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.mi/Makefile" ;;
"gdb.modula2/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.modula2/Makefile" ;;

View File

@ -95,7 +95,7 @@ AC_OUTPUT([Makefile \
gdb.server/Makefile gdb.java/Makefile \
gdb.hp/Makefile gdb.hp/gdb.objdbg/Makefile gdb.hp/gdb.base-hp/Makefile \
gdb.hp/gdb.aCC/Makefile gdb.hp/gdb.compat/Makefile \
gdb.hp/gdb.defects/Makefile gdb.linespec/Makefile \
gdb.hp/gdb.defects/Makefile gdb.guile/Makefile gdb.linespec/Makefile \
gdb.mi/Makefile gdb.modula2/Makefile gdb.multi/Makefile \
gdb.objc/Makefile gdb.opencl/Makefile gdb.opt/Makefile gdb.pascal/Makefile \
gdb.perf/Makefile gdb.python/Makefile gdb.reverse/Makefile gdb.stabs/Makefile \

View File

@ -124,4 +124,4 @@ gdb_test "apropos \\\(print\[\^ bsiedf\\\".-\]\\\)" "handle -- Specify how to ha
# test apropos >1 word string
gdb_test "apropos handle signal" "handle -- Specify how to handle signals"
# test apropos apropos
gdb_test "apropos apropos" "apropos -- Search for commands matching a REGEXP"
gdb_test "apropos apropos" "apropos -- Search for commands matching a REGEXP.*"

View File

@ -0,0 +1,17 @@
VPATH = @srcdir@
srcdir = @srcdir@
EXECUTABLES =
MISCELLANEOUS =
all info install-info dvi install uninstall installcheck check:
@echo "Nothing to be done for $@..."
clean mostlyclean:
-rm -f *~ *.o *.ci
-rm -f *.dwo *.dwp
-rm -f core $(EXECUTABLES) $(MISCELLANEOUS)
distclean maintainer-clean realclean: clean
-rm -f Makefile config.status config.log gdb.log gdb.sum

View File

@ -0,0 +1,77 @@
# Copyright (C) 2008-2014 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 basic Guile features.
load_lib gdb-guile.exp
# Start with a fresh gdb.
gdb_exit
gdb_start
gdb_reinitialize_dir $srcdir/$subdir
# Do this instead of the skip_guile_check.
# We want to do some tests when Guile is not present.
gdb_test_multiple "guile (display 23) (newline)" "verify guile support" {
-re "Undefined command.*$gdb_prompt $" {
unsupported "Guile not supported."
return
}
-re "not supported.*$gdb_prompt $" {
unsupported "guile support is disabled"
# If Guile is not supported, verify that sourcing a guile script
# causes an error.
gdb_test "source $srcdir/$subdir/source2.scm" \
"Error in sourced command file:.*" \
"source source2.scm when guile disabled"
return
}
-re "$gdb_prompt $" {}
}
gdb_install_guile_utils
gdb_install_guile_module
gdb_test_multiline "multi-line guile command" \
"guile" "" \
"(print 23)" "" \
"end" "= 23"
gdb_test_multiline "show guile command" \
"define zzq" "Type commands for definition of .* just \"end\"\\.*" \
"guile" "" \
"(print 23)" "" \
"end" "" \
"end" "" \
"show user zzq" "User command \"zzq\":.* guile.*\\(print 23\\).* end"
gdb_test "source $srcdir/$subdir/source2.scm" "yes" "source source2.scm"
gdb_test "source -s source2.scm" "yes" "source -s source2.scm"
gdb_test "guile (print (current-objfile))" "= #f"
gdb_test "guile (print (objfiles))" "= \\(\\)"
gdb_test_no_output \
{guile (define x (execute "printf \"%d\", 23" #:to-string #t))}
gdb_test "guile (print x)" "= 23"
gdb_test_no_output "guile (define a (execute \"help\" #:to-string #t))" \
"collect help from uiout"
gdb_test "guile (print a)" "= .*aliases -- Aliases of other commands.*" \
"verify help to uiout"

View File

@ -0,0 +1,22 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2014 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
main (void)
{
return 0;
}

View File

@ -0,0 +1,33 @@
# Copyright 2014 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/>.
load_lib gdb-guile.exp
standard_testfile
if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
return
}
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
if ![gdb_guile_runto_main] {
return
}
gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" "get frame"
gdb_scm_test_silent_cmd "guile (define arch (frame-arch frame))" "get arch"
gdb_scm_test_silent_cmd "guile (define pc (frame-pc frame))" "get pc"

View File

@ -0,0 +1,38 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2010-2014 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. */
}

View File

@ -0,0 +1,107 @@
# Copyright (C) 2010-2014 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"

View File

@ -0,0 +1,44 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2010-2014 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 result = 0;
int multiply (int i)
{
return i * i;
}
int add (int i)
{
return i + i;
}
int main (int argc, char *argv[])
{
int foo = 5;
int bar = 42;
int i;
for (i = 0; i < 10; i++)
{
result += multiply (foo); /* Break at multiply. */
result += add (bar); /* Break at add. */
}
return 0; /* Break at end. */
}

View File

@ -0,0 +1,438 @@
# Copyright (C) 2010-2014 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 breakpoints 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 }
proc test_bkpt_basic { } {
global srcfile testfile hex decimal
with_test_prefix "test_bkpt_basic" {
# Start with a fresh gdb.
clean_restart ${testfile}
if ![gdb_guile_runto_main] {
return
}
# Initially there should be one breakpoint: main.
gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
"get breakpoint list 1"
gdb_test "guile (print (car blist))" \
"<gdb:breakpoint #1 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @main>" \
"check main breakpoint"
gdb_test "guile (print (breakpoint-location (car blist)))" \
"main" "check main breakpoint location"
set mult_line [gdb_get_line_number "Break at multiply."]
gdb_breakpoint ${mult_line}
gdb_continue_to_breakpoint "Break at multiply."
# Check that the Guile breakpoint code noted the addition of a
# breakpoint "behind the scenes".
gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
"get breakpoint list 2"
gdb_scm_test_silent_cmd "guile (define mult-bkpt (cadr blist))" \
"get multiply breakpoint"
gdb_test "guile (print (length blist))" \
"= 2" "check for two breakpoints"
gdb_test "guile (print mult-bkpt)" \
"= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @.*scm-breakpoint.c:$mult_line>" \
"check multiply breakpoint"
gdb_test "guile (print (breakpoint-location mult-bkpt))" \
"scm-breakpoint\.c:${mult_line}*" \
"check multiply breakpoint location"
# Check hit and ignore counts.
gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \
"= 1" "check multiply breakpoint hit count"
gdb_scm_test_silent_cmd "guile (set-breakpoint-ignore-count! mult-bkpt 4)" \
"set multiply breakpoint ignore count"
gdb_continue_to_breakpoint "Break at multiply."
gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \
"= 6" "check multiply breakpoint hit count 2"
gdb_test "print result" \
" = 545" "check expected variable result after 6 iterations"
# Test breakpoint is enabled and disabled correctly.
gdb_breakpoint [gdb_get_line_number "Break at add."]
gdb_continue_to_breakpoint "Break at add."
gdb_test "guile (print (breakpoint-enabled? mult-bkpt))" \
"= #t" "check multiply breakpoint enabled"
gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #f)" \
"set multiply breakpoint disabled"
gdb_continue_to_breakpoint "Break at add."
gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #t)" \
"set multiply breakpoint enabled"
gdb_continue_to_breakpoint "Break at multiply."
# Test other getters and setters.
gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
"get breakpoint list 3"
gdb_test "guile (print (breakpoint-thread mult-bkpt))" \
"= #f" "check breakpoint thread"
gdb_test "guile (print (= (breakpoint-type mult-bkpt) BP_BREAKPOINT))" \
"= #t" "check breakpoint type"
gdb_test "guile (print (map breakpoint-number blist))" \
"= \\(1 2 3\\)" "check breakpoint numbers"
}
}
proc test_bkpt_deletion { } {
global srcfile testfile hex decimal
with_test_prefix test_bkpt_deletion {
# Start with a fresh gdb.
clean_restart ${testfile}
if ![gdb_guile_runto_main] {
return
}
# Test breakpoints are deleted correctly.
set deltst_location [gdb_get_line_number "Break at multiply."]
set end_location [gdb_get_line_number "Break at end."]
gdb_scm_test_silent_cmd "guile (define dp1 (create-breakpoint! \"$deltst_location\"))" \
"create deltst breakpoint"
gdb_breakpoint [gdb_get_line_number "Break at end."]
gdb_scm_test_silent_cmd "guile (define del-list (breakpoints))" \
"get breakpoint list 4"
gdb_test "guile (print (length del-list))" \
"= 3" "number of breakpoints before delete"
gdb_continue_to_breakpoint "Break at multiply." \
".*/$srcfile:$deltst_location.*"
gdb_scm_test_silent_cmd "guile (breakpoint-delete! dp1)" \
"delete breakpoint"
gdb_test "guile (print (breakpoint-number dp1))" \
"ERROR: .*: Invalid object: <gdb:breakpoint> in position 1: #<gdb:breakpoint #2>.*" \
"check breakpoint invalidated"
gdb_scm_test_silent_cmd "guile (set! del-list (breakpoints))" \
"get breakpoint list 5"
gdb_test "guile (print (length del-list))" \
"= 2" "number of breakpoints after delete"
gdb_continue_to_breakpoint "Break at end." ".*/$srcfile:$end_location.*"
}
}
proc test_bkpt_cond_and_cmds { } {
global srcfile testfile hex decimal
with_test_prefix test_bkpt_cond_and_cmds {
# Start with a fresh gdb.
clean_restart ${testfile}
if ![gdb_guile_runto_main] {
return
}
# Test conditional setting.
set bp_location1 [gdb_get_line_number "Break at multiply."]
gdb_scm_test_silent_cmd "guile (define bp1 (create-breakpoint! \"$bp_location1\"))" \
"create multiply breakpoint"
gdb_continue_to_breakpoint "Break at multiply."
gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 \"i == 5\")" \
"set condition"
gdb_test "guile (print (breakpoint-condition bp1))" \
"= i == 5" "test condition has been set"
gdb_continue_to_breakpoint "Break at multiply."
gdb_test "print i" \
"5" "test conditional breakpoint stopped after five iterations"
gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 #f)" \
"clear condition"
gdb_test "guile (print (breakpoint-condition bp1))" \
"= #f" "test condition has been removed"
gdb_continue_to_breakpoint "Break at multiply."
gdb_test "print i" "6" "test breakpoint stopped after six iterations"
# Test commands.
gdb_breakpoint [gdb_get_line_number "Break at add."]
set test {commands $bpnum}
gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
set test {print "Command for breakpoint has been executed."}
gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
set test {print result}
gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
gdb_test "end"
gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
"get breakpoint list 6"
gdb_test "guile (print (breakpoint-commands (list-ref blist (- (length blist) 1))))" \
"print \"Command for breakpoint has been executed.\".*print result"
}
}
proc test_bkpt_invisible { } {
global srcfile testfile hex decimal
with_test_prefix test_bkpt_invisible {
# Start with a fresh gdb.
clean_restart ${testfile}
if ![gdb_guile_runto_main] {
return
}
# Test invisible breakpoints.
delete_breakpoints
set ibp_location [gdb_get_line_number "Break at multiply."]
gdb_scm_test_silent_cmd "guile (define vbp (create-breakpoint! \"$ibp_location\" #:internal #f))" \
"create visible breakpoint"
gdb_scm_test_silent_cmd "guile (define vbp (car (breakpoints)))" \
"get visible breakpoint"
gdb_test "guile (print vbp)" \
"= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
"check visible bp obj exists"
gdb_test "guile (print (breakpoint-location vbp))" \
"scm-breakpoint\.c:$ibp_location*" "check visible breakpoint location"
gdb_test "guile (print (breakpoint-visible? vbp))" \
"= #t" "check breakpoint visibility"
gdb_test "info breakpoints" \
"scm-breakpoint\.c:$ibp_location.*" \
"check info breakpoints shows visible breakpoints"
delete_breakpoints
gdb_scm_test_silent_cmd "guile (define ibp (create-breakpoint! \"$ibp_location\" #:internal #t))" \
"create invisible breakpoint"
gdb_test "guile (print ibp)" \
"= #<gdb:breakpoint #-$decimal BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
"check invisible bp obj exists"
gdb_test "guile (print (breakpoint-location ibp))" \
"scm-breakpoint\.c:$ibp_location*" "check invisible breakpoint location"
gdb_test "guile (print (breakpoint-visible? ibp))" \
"= #f" "check breakpoint invisibility"
gdb_test "info breakpoints" \
"No breakpoints or watchpoints.*" \
"check info breakpoints does not show invisible breakpoints"
gdb_test "maint info breakpoints" \
"scm-breakpoint\.c:$ibp_location.*" \
"check maint info breakpoints shows invisible breakpoints"
}
}
proc test_watchpoints { } {
global srcfile testfile hex decimal
with_test_prefix test_watchpoints {
# Start with a fresh gdb.
clean_restart ${testfile}
# Disable hardware watchpoints if necessary.
if [target_info exists gdb,no_hardware_watchpoints] {
gdb_test_no_output "set can-use-hw-watchpoints 0" ""
}
if ![gdb_guile_runto_main] {
return
}
gdb_scm_test_silent_cmd "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \
"create watchpoint"
gdb_test "continue" \
".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \
"test watchpoint write"
}
}
proc test_bkpt_internal { } {
global srcfile testfile hex decimal
with_test_prefix test_bkpt_internal {
# Start with a fresh gdb.
clean_restart ${testfile}
# Disable hardware watchpoints if necessary.
if [target_info exists gdb,no_hardware_watchpoints] {
gdb_test_no_output "set can-use-hw-watchpoints 0" ""
}
if ![gdb_guile_runto_main] {
return
}
delete_breakpoints
gdb_scm_test_silent_cmd "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE #:internal #t))" \
"create invisible watchpoint"
gdb_test "info breakpoints" \
"No breakpoints or watchpoints.*" \
"check info breakpoints does not show invisible watchpoint"
gdb_test "maint info breakpoints" \
".*watchpoint.*result.*" \
"check maint info breakpoints shows invisible watchpoint"
gdb_test "continue" \
".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*" \
"test invisible watchpoint write"
}
}
proc test_bkpt_eval_funcs { } {
global srcfile testfile hex decimal
with_test_prefix test_bkpt_eval_funcs {
# Start with a fresh gdb.
clean_restart ${testfile}
# Disable hardware watchpoints if necessary.
if [target_info exists gdb,no_hardware_watchpoints] {
gdb_test_no_output "set can-use-hw-watchpoints 0" ""
}
if ![gdb_guile_runto_main] {
return
}
delete_breakpoints
gdb_test_multiline "data collection breakpoint 1" \
"guile" "" \
"(define (make-bp-data) (cons 0 0))" "" \
"(define bp-data-count car)" "" \
"(define set-bp-data-count! set-car!)" "" \
"(define bp-data-inf-i cdr)" "" \
"(define set-bp-data-inf-i! set-cdr!)" "" \
"(define (bp-eval-count bkpt) (bp-data-count (gsmob-property bkpt 'bp-data)))" "" \
"(define (bp-eval-inf-i bkpt) (bp-data-inf-i (gsmob-property bkpt 'bp-data)))" "" \
"(define (make-bp-eval location)" "" \
" (let ((bp (create-breakpoint! location)))" "" \
" (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
" (set-breakpoint-stop! bp" "" \
" (lambda (bkpt)" "" \
" (let ((data (gsmob-property bkpt 'bp-data))" "" \
" (inf-i (parse-and-eval \"i\")))" "" \
" (set-bp-data-count! data (+ (bp-data-count data) 1))" "" \
" (set-bp-data-inf-i! data inf-i)" "" \
" (value=? inf-i 3))))" "" \
" bp))" "" \
"end" ""
gdb_test_multiline "data collection breakpoint 2" \
"guile" "" \
"(define (make-bp-also-eval location)" "" \
" (let ((bp (create-breakpoint! location)))" "" \
" (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
" (set-breakpoint-stop! bp" "" \
" (lambda (bkpt)" "" \
" (let* ((data (gsmob-property bkpt 'bp-data))" "" \
" (count (+ (bp-data-count data) 1)))" "" \
" (set-bp-data-count! data count)" "" \
" (= count 9))))" "" \
" bp))" "" \
"end" ""
gdb_test_multiline "data collection breakpoint 3" \
"guile" "" \
"(define (make-bp-basic location)" "" \
" (let ((bp (create-breakpoint! location)))" "" \
" (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
" bp))" "" \
"end" ""
set bp_location2 [gdb_get_line_number "Break at multiply."]
set end_location [gdb_get_line_number "Break at end."]
gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$bp_location2\"))" \
"create eval-bp1 breakpoint"
gdb_scm_test_silent_cmd "guile (define also-eval-bp1 (make-bp-also-eval \"$bp_location2\"))" \
"create also-eval-bp1 breakpoint"
gdb_scm_test_silent_cmd "guile (define never-eval-bp1 (make-bp-also-eval \"$end_location\"))" \
"create never-eval-bp1 breakpoint"
gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*"
gdb_test "print i" "3" "check inferior value matches guile accounting"
gdb_test "guile (print (bp-eval-inf-i eval-bp1))" \
"= 3" "check guile accounting matches inferior"
gdb_test "guile (print (bp-eval-count also-eval-bp1))" \
"= 4" \
"check non firing same-location breakpoint eval function was also called at each stop 1"
gdb_test "guile (print (bp-eval-count eval-bp1))" \
"= 4" \
"check non firing same-location breakpoint eval function was also called at each stop 2"
# Check we cannot assign a condition to a breakpoint with a stop-func,
# and cannot assign a stop-func to a breakpoint with a condition.
delete_breakpoints
set cond_bp [gdb_get_line_number "Break at multiply."]
gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$cond_bp\"))" \
"create eval-bp1 breakpoint 2"
set test_cond {cond $bpnum}
gdb_test "$test_cond \"foo==3\"" \
"Only one stop condition allowed.*"
gdb_scm_test_silent_cmd "guile (define eval-bp2 (make-bp-basic \"$cond_bp\"))" \
"create basic breakpoint"
gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! eval-bp2 \"1==1\")" \
"set a condition"
gdb_test_multiline "construct an eval function" \
"guile" "" \
"(define (stop-func bkpt)" "" \
" return #t)" "" \
"end" ""
gdb_test "guile (set-breakpoint-stop! eval-bp2 stop-func)" \
"Only one stop condition allowed.*"
# Check that stop-func is run when location has normal bp.
delete_breakpoints
gdb_breakpoint [gdb_get_line_number "Break at multiply."]
gdb_scm_test_silent_cmd "guile (define check-eval (make-bp-eval \"$bp_location2\"))" \
"create check-eval breakpoint"
gdb_test "guile (print (bp-eval-count check-eval))" \
"= 0" \
"test that evaluate function has not been yet executed (ie count = 0)"
gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*"
gdb_test "guile (print (bp-eval-count check-eval))" \
"= 1" \
"test that evaluate function is run when location also has normal bp"
# Test watchpoints with stop-func.
gdb_test_multiline "watchpoint stop func" \
"guile" "" \
"(define (make-wp-eval location)" "" \
" (let ((wp (create-breakpoint! location #:type BP_WATCHPOINT #:wp-class WP_WRITE)))" "" \
" (set-breakpoint-stop! wp" "" \
" (lambda (bkpt)" "" \
" (let ((result (parse-and-eval \"result\")))" "" \
" (value=? result 788))))" "" \
" wp))" "" \
"end" ""
delete_breakpoints
gdb_scm_test_silent_cmd "guile (define wp1 (make-wp-eval \"result\"))" \
"create watchpoint"
gdb_test "continue" ".*\[Ww\]atchpoint.*result.*Old value =.*New value = 788.*" \
"test watchpoint write"
# Misc final tests.
gdb_test "guile (print (bp-eval-count never-eval-bp1))" \
"= 0" \
"check that this unrelated breakpoints eval function was never called"
}
}
test_bkpt_basic
test_bkpt_deletion
test_bkpt_cond_and_cmds
test_bkpt_invisible
test_watchpoints
test_bkpt_internal
test_bkpt_eval_funcs

View File

@ -0,0 +1,22 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2014 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
main (void)
{
return 0;
}

View File

@ -0,0 +1,133 @@
# Copyright 2014 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/>.
load_lib gdb-guile.exp
standard_testfile
if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
return
}
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
if ![gdb_guile_runto_main] {
return
}
# Disassemble one instruction at pc and verify the result.
proc test_disassemble_1 { name address extra_args } {
with_test_prefix $name {
gdb_scm_test_silent_cmd "guile (define insn-list (arch-disassemble arch $address $extra_args #:size 1 #:count 1))" \
"disassemble"
gdb_test "guile (print (length insn-list))" \
"= 1" "test number of instructions"
gdb_scm_test_silent_cmd "guile (define insn (car insn-list))" \
"get instruction"
# Verify all the fields are present.
gdb_test "guile (print (->bool (assq-ref insn 'address)))" \
"= #t" "test key address"
gdb_test "guile (print (->bool (assq-ref insn 'asm)))" \
"= #t" "test key asm"
gdb_test "guile (print (->bool (assq-ref insn 'length)))" \
"= #t" "test key length"
# Verify the correct address is used.
gdb_test "guile (print (= $address (assq-ref insn 'address)))" \
"= #t" "verify correct address"
}
}
gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" "get frame"
gdb_scm_test_silent_cmd "guile (define arch (frame-arch frame))" "get arch"
gdb_scm_test_silent_cmd "guile (define pc (frame-pc frame))" "get pc"
gdb_test "guile (print (arch-disassemble arch pc #:size 0))" \
"= \\(\\)" "disassemble, zero size"
gdb_test "guile (print (arch-disassemble arch pc #:count 0))" \
"= \\(\\)" "disassemble, zero count"
gdb_scm_test_silent_cmd "guile (define insn-list1 (arch-disassemble arch pc #:size 1 #:count 1))" \
"disassemble"
gdb_scm_test_silent_cmd "guile (define insn-list2 (arch-disassemble arch pc #:size 1))" \
"disassemble, no count"
gdb_scm_test_silent_cmd "guile (define insn-list3 (arch-disassemble arch pc #:count 1))" \
"disassemble, no end"
gdb_scm_test_silent_cmd "guile (define insn-list4 (arch-disassemble arch pc))" \
"disassemble, no end no count"
gdb_test "guile (print (length insn-list1))" \
"= 1" "test number of instructions 1"
gdb_test "guile (print (length insn-list2))" \
"= 1" "test number of instructions 2"
gdb_test "guile (print (length insn-list3))" \
"= 1" "test number of instructions 3"
gdb_test "guile (print (length insn-list4))" \
"= 1" "test number of instructions 4"
test_disassemble_1 "basic" "pc" ""
# Negative test
gdb_test "guile (arch-disassemble arch 0 #:size 1)" \
"ERROR: Cannot access memory at address 0x.*" "test bad memory access"
# Test disassembly through a port.
gdb_scm_test_silent_cmd "guile (define mem (open-memory))" \
"open memory port"
test_disassemble_1 "memory-port" "pc" "#:port mem"
gdb_scm_test_silent_cmd "guile (define insn-list-mem (arch-disassemble arch pc #:port mem #:size 1 #:count 1))" \
"disassemble via memory port"
# Test memory error reading from port.
gdb_scm_test_silent_cmd "guile (define mem1 (open-memory #:start pc #:size 4))" \
"open restricted range memory port"
# The x86 disassembler tries to be clever and will print "byte 0x42" if
# there is insufficient memory for the entire instruction.
# So we pass "#:count 5" to ensure the disassembler tries to read beyond
# the end of the memory range.
gdb_test "guile (arch-disassemble arch pc #:port mem1 #:count 5 #:offset pc)" \
"ERROR: Cannot access memory at address 0x.*" \
"test bad memory access from port"
# Test disassembly of a bytevector.
gdb_scm_test_silent_cmd "guile (use-modules (rnrs io ports))" \
"import (rnrs io ports)"
# First fetch the length of the instruction at $pc.
gdb_scm_test_silent_cmd "guile (define insn-list-for-bv (arch-disassemble arch pc))" \
"get insn for bytevector"
gdb_test_no_output "guile (define insn-length (assq-ref (car insn-list-for-bv) 'length))" \
"get insn length for bytevector"
# Read the insn into a bytevector.
gdb_test_no_output "guile (define insn-bv (get-bytevector-n (open-memory #:start pc #:size insn-length) insn-length))" \
"read insn into bytevector"
# Disassemble the bytevector.
gdb_scm_test_silent_cmd "guile (define insn-list-from-bv (arch-disassemble arch pc #:port (open-bytevector-input-port insn-bv) #:offset pc))" \
"disassemble bytevector"
gdb_test "guile (print (equal? insn-list-for-bv insn-list-from-bv))" \
"= #t" "verify bytevector disassembly"

View File

@ -0,0 +1,24 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2014 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 x;
int
main (void)
{
return x;
}

View File

@ -0,0 +1,55 @@
# Copyright 2014 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 equal? for the various gsmobs.
load_lib gdb-guile.exp
standard_testfile
if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
return
}
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
if ![gdb_guile_runto_main] {
return
}
gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" "get frame"
gdb_scm_test_silent_cmd "guile (define arch (frame-arch frame))" "get arch"
gdb_test "guile (print (equal? (selected-frame) (newest-frame)))" \
"= #t" "equal? frame"
gdb_test "guile (print (equal? (selected-frame) (frame-older (newest-frame))))" \
"= #f" "not equal? frame"
gdb_test "guile (print (equal? (make-value 1) (make-value 1)))" \
"= #t" "equal? value"
gdb_test "guile (print (equal? (make-value 1) (make-value 2)))" \
"= #f" "not equal? value"
gdb_test "guile (print (equal? (value-type (make-value 1)) (value-type (make-value 2))))" \
"= #t" "equal? type"
gdb_test "guile (print (equal? (value-type (make-value 1)) (value-type (make-value 2.5))))" \
"= #f" "not equal? type"
gdb_test "guile (print (equal? (lookup-global-symbol \"main\") (lookup-global-symbol \"main\")))" \
"= #t" "equal? symbol"
gdb_test "guile (print (equal? (lookup-global-symbol \"main\") (lookup-global-symbol \"x\")))" \
"= #f" "not equal? symbol"

View File

@ -0,0 +1,19 @@
;; Copyright (C) 2014 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/>.
(use-modules (gdb))
;; An intentional error to test error handling when loading a file.
(define foo (+ 42 #f))

View File

@ -0,0 +1,30 @@
;; Copyright (C) 2014 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/>.
(use-modules (gdb))
;; Create a set of functions to call, with the last one having an error,
;; so we can test backtrace printing.
(define foo #f)
(define (top-func x)
(+ (middle-func x) 1))
(define (middle-func x)
(+ (bottom-func x) 1))
(define (bottom-func x)
(+ x foo))

View File

@ -0,0 +1,117 @@
# Copyright (C) 2010-2014 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/>.
# Test various error conditions.
set testfile "scm-error"
load_lib gdb-guile.exp
# Start with a fresh gdb.
gdb_exit
gdb_start
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
# Test error while loading .scm.
# Give the files a new name so we don't clobber the real one if
# objfile == srcdir.
set remote_guile_file_1 [gdb_remote_download host \
${srcdir}/${subdir}/${testfile}-1.scm \
${subdir}/t-${testfile}-1.scm]
set remote_guile_file_2 [gdb_remote_download host \
${srcdir}/${subdir}/${testfile}-2.scm \
${subdir}/t-${testfile}-2.scm]
gdb_test "source $remote_guile_file_1" \
"(ERROR: )?In procedure \[+\]: Wrong type: #f.*" \
"error loading scm file caught"
gdb_test "p 1" " = 1" "no delayed error"
# Test setting/showing the various states for "guile print-stack".
gdb_test "show guile print-stack" \
"The mode of Guile exception printing on error is \"message\".*" \
"test print-stack show setting of default"
gdb_test_no_output "set guile print-stack full" \
"test print-stack full setting"
gdb_test "show guile print-stack" \
"The mode of Guile exception printing on error is \"full\".*" \
"test print-stack show setting to full"
gdb_test_no_output "set guile print-stack none" \
"test print-stack none setting"
gdb_test "show guile print-stack" \
"The mode of Guile exception printing on error is \"none\".*" \
"test print-stack show setting to none"
# Reset back to default, just in case.
gdb_test_no_output "set guile print-stack message" \
"reset print-stack to default, post set/show tests"
# Test "set guile print-stack none".
gdb_test_no_output "set guile print-stack none" \
"set print-stack to none, for error test"
set test_name "no error printed"
set command "guile (define x doesnt-exist)"
gdb_test_multiple $command $test_name {
-re "Backtrace.*$gdb_prompt $" { fail $test_name }
-re "ERROR.*$gdb_prompt $" { fail $test_name }
-re "$gdb_prompt $" { pass $test_name }
}
# Test "set guile print-stack message".
gdb_test_no_output "set guile print-stack message" \
"set print-stack to message, for error test"
set test_name "error message printed"
set command "guile (define x doesnt-exist)"
gdb_test_multiple $command $test_name {
-re "Backtrace.*$gdb_prompt $" { fail $test_name }
-re "ERROR.*$gdb_prompt $" { pass $test_name }
}
# Test "set guile print-stack full".
gdb_scm_test_silent_cmd "source $remote_guile_file_2" ""
gdb_test_no_output "set guile print-stack full" \
"set print-stack to full, for backtrace test"
gdb_test "guile (define x (top-func 42))" \
"Guile Backtrace:.*top-func 42.*middle-func 42.*bottom-func 42.*" \
"backtrace printed"
# Verify gdb-specific errors are printed properly.
# i.e., each gdb error is registered to use init.scm:%error-printer.
gdb_test_no_output "set guile print-stack message" \
"set print-stack to message, for error printing tests"
gdb_test "guile (throw 'gdb:error \"subr\" \"misc error: ~a\" (list 42))" \
"ERROR: In procedure subr: misc error: 42.*"
gdb_test "guile (throw 'gdb:invalid-object-error \"subr\" \"invalid object error: ~a\" (list 42))" \
"ERROR: In procedure subr: invalid object error: 42.*"
gdb_test "guile (throw 'gdb:memory-error \"subr\" \"memory error: ~a\" (list 42))" \
"ERROR: In procedure subr: memory error: 42.*"
gdb_test "guile (throw 'gdb:pp-type-error \"subr\" \"pp-type error: ~a\" (list 42))" \
"ERROR: In procedure subr: pp-type error: 42.*"

View File

@ -0,0 +1,60 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2014 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/>. */
#include <string.h>
struct s
{
int m;
};
struct ss
{
struct s a;
struct s b;
};
void
init_s (struct s *s, int m)
{
s->m = m;
}
void
init_ss (struct ss *s, int a, int b)
{
init_s (&s->a, a);
init_s (&s->b, b);
}
void
foo (int x, struct ss ss)
{
return; /* break-here */
}
int
main ()
{
struct ss ss;
init_ss (&ss, 1, 2);
foo (42, ss);
return 0;
}

View File

@ -0,0 +1,76 @@
# Copyright (C) 2014 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/>.
load_lib gdb-guile.exp
standard_testfile
if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
return
}
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
if ![gdb_guile_runto_main] {
return
}
# Give the file a new name so we don't clobber the real one if
# objfile == srcdir.
set remote_guile_file [gdb_remote_download host \
${srcdir}/${subdir}/${testfile}.scm \
${subdir}/t-${testfile}.scm]
gdb_scm_load_file "$remote_guile_file" "load script"
gdb_breakpoint [gdb_get_line_number "break-here"]
gdb_continue_to_breakpoint "break-here" ".* break-here .*"
# Test all combinations with raw off.
gdb_test_no_output "set print raw frame-arguments off"
gdb_test_no_output "set print frame-arguments none"
gdb_test "frame" ".*foo \\(x=\[.\]{3}, ss=\[.\]{3}\\).*" \
"frame pretty,none"
#gdb_test_no_output "set guile print-stack full"
gdb_test_no_output "set print frame-arguments scalars"
gdb_test "frame" ".*foo \\(x=42, ss=super struct = {\[.\]{3}}\\).*" \
"frame pretty,scalars"
gdb_test_no_output "set print frame-arguments all"
gdb_test "frame" \
".*foo \\(x=42, ss=super struct = {a = m=<1>, b = m=<2>}\\).*" \
"frame pretty,all"
# Test all combinations with raw on.
gdb_test_no_output "set print raw frame-arguments on"
gdb_test_no_output "set print frame-arguments none"
gdb_test "frame" ".*foo \\(x=\[.\]{3}, ss=\[.\]{3}\\).*" \
"frame raw,none"
gdb_test_no_output "set print frame-arguments scalars"
gdb_test "frame" ".*foo \\(x=42, ss=\[.\]{3}\\).*" \
"frame raw,scalars"
gdb_test_no_output "set print frame-arguments all"
gdb_test "frame" \
".*foo \\(x=42, ss={a = {m = 1}, b = {m = 2}}\\).*" \
"frame raw,all"

View File

@ -0,0 +1,69 @@
;; Copyright (C) 2014 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/>.
(use-modules (gdb) (gdb printing))
(define (make-pp_s-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(let ((m (value-field val "m")))
(format #f "m=<~A>" m)))
#f))
(define (make-pp_ss-printer val)
(make-pretty-printer-worker
#f
(lambda (printer) "super struct")
(lambda (printer)
(make-iterator val
(make-field-iterator (value-type val))
(lambda (iter)
(let ((field (iterator-next!
(iterator-progress iter))))
(if (end-of-iteration? field)
field
(let ((name (field-name field)))
(cons name (value-field val name))))))))))
(define (get-type-for-printing val)
"Return type of val, stripping away typedefs, etc."
(let ((type (value-type val)))
(if (= (type-code type) TYPE_CODE_REF)
(set! type (type-target type)))
(type-strip-typedefs (type-unqualified type))))
(define (make-pretty-printer-dict)
(let ((dict (make-hash-table)))
(hash-set! dict "struct s" make-pp_s-printer)
(hash-set! dict "s" make-pp_s-printer)
(hash-set! dict "struct ss" make-pp_ss-printer)
(hash-set! dict "ss" make-pp_ss-printer)
dict))
(define *pretty-printer*
(make-pretty-printer
"pretty-printer-test"
(let ((pretty-printers-dict (make-pretty-printer-dict)))
(lambda (matcher val)
"Look-up and return a pretty-printer that can print val."
(let ((type (get-type-for-printing val)))
(let ((typename (type-tag type)))
(if typename
(let ((printer-maker (hash-ref pretty-printers-dict typename)))
(and printer-maker (printer-maker val)))
#f)))))))
(append-pretty-printer! #f *pretty-printer*)

View File

@ -0,0 +1,43 @@
/* This test is part of GDB, the GNU debugger.
Copyright 2011-2014 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/>. */
volatile int v = 42;
__attribute__((__always_inline__)) static inline int
f (void)
{
/* Provide first stub line so that GDB understand the PC is already inside
the inlined function and does not expect a step into it. */
v++;
v++; /* break-here */
return v;
}
__attribute__((__noinline__)) static int
g (void)
{
volatile int l = v;
return f ();
}
int
main (void)
{
return g ();
}

View File

@ -0,0 +1,43 @@
# Copyright (C) 2011-2014 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/>.
load_lib gdb-guile.exp
standard_testfile
if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
return
}
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
if ![runto main] {
fail "Can't run to main"
return
}
gdb_install_guile_utils
gdb_install_guile_module
gdb_breakpoint [gdb_get_line_number "break-here"]
gdb_continue_to_breakpoint "break-here"
gdb_test "info frame" "inlined into frame 1\r\n.*"
gdb_test "up" "#1 g .*"
gdb_test "guile (print (frame-read-var (selected-frame) \"l\"))" \
"= 42"

View File

@ -0,0 +1,30 @@
int f2 (int a)
{
return ++a;
}
int f1 (int a, int b)
{
return f2(a) + b;
}
int block (void)
{
int i = 99;
{
double i = 1.1;
double f = 2.2;
{
const char *i = "stuff";
const char *f = "foo";
const char *b = "bar";
return 0; /* Block break here. */
}
}
}
int main (int argc, char *argv[])
{
block ();
return f1 (1, 2);
}

View File

@ -0,0 +1,122 @@
# Copyright (C) 2009-2014 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 frame support in 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 }
# The following tests require execution.
if ![gdb_guile_runto_main] {
return
}
gdb_breakpoint [gdb_get_line_number "Block break here."]
gdb_continue_to_breakpoint "Block break here."
gdb_scm_test_silent_cmd "guile (define bf1 (selected-frame))" \
"get frame"
# Test frame-architecture method.
gdb_scm_test_silent_cmd "guile (define show-arch-str (execute \"show architecture\" #:to-string #t))" \
"show arch"
gdb_test "guile (print (->bool (string-contains show-arch-str (arch-name (frame-arch bf1)))))" \
"#t" "test frame-arch"
# First test that read-var is unaffected by PR 11036 changes.
gdb_test "guile (print (frame-read-var bf1 \"i\"))" \
"\"stuff\"" "test i"
gdb_test "guile (print (frame-read-var bf1 \"f\"))" \
"\"foo\"" "test f"
gdb_test "guile (print (frame-read-var bf1 \"b\"))" \
"\"bar\"" "test b"
# Test the read-var function in another block other than the current
# block (in this case, the super block). Test thar read-var is reading
# the correct variables of i and f but they are the correct value and type.
gdb_scm_test_silent_cmd "guile (define sb (block-superblock (frame-block bf1)))" \
"get superblock"
gdb_test "guile (print (frame-read-var bf1 \"i\" #:block sb))" "1.1.*" \
"test i = 1.1"
gdb_test "guile (print (value-type (frame-read-var bf1 \"i\" #:block sb)))" \
"double" "test double i"
gdb_test "guile (print (frame-read-var bf1 \"f\" #:block sb))" \
"2.2.*" "test f = 2.2"
gdb_test "guile (print (value-type (frame-read-var bf1 \"f\" #:block sb)))" \
"double" "test double f"
# And again test another outerblock, this time testing "i" is the
# correct value and type.
gdb_scm_test_silent_cmd "guile (set! sb (block-superblock sb))" \
"get superblock #2"
gdb_test "guile (print (frame-read-var bf1 \"i\" #:block sb))" \
"99" "test i = 99"
gdb_test "guile (print (value-type (frame-read-var bf1 \"i\" #:block sb)))" \
"int" "test int i"
gdb_breakpoint "f2"
gdb_continue_to_breakpoint "breakpoint at f2"
gdb_scm_test_silent_cmd "guile (define bframe (selected-frame))" \
"get bottom-most frame"
gdb_test "up" ".*" ""
gdb_scm_test_silent_cmd "guile (define f1 (selected-frame))" \
"get second frame"
gdb_scm_test_silent_cmd "guile (define f0 (frame-newer f1))" \
"get first frame"
gdb_test "guile (print (eq? f1 (newest-frame)))" \
#f "selected frame -vs- newest frame"
gdb_test "guile (print (eq? bframe (newest-frame)))" \
#t "newest frame -vs- newest frame"
gdb_test "guile (print (eq? f0 f1))" \
"#f" "test equality comparison (false)"
gdb_test "guile (print (eq? f0 f0))" \
"#t" "test equality comparison (true)"
gdb_test "guile (print (frame-valid? f0))" \
"#t" "test frame-valid?"
gdb_test "guile (print (frame-name f0))" \
"f2" "test frame-name"
gdb_test "guile (print (= (frame-type f0) NORMAL_FRAME))" \
"#t" "test frame-type"
gdb_test "guile (print (= (frame-unwind-stop-reason f0) FRAME_UNWIND_NO_REASON))" \
"#t" "test frame-unwind-stop-reason"
gdb_test "guile (print (unwind-stop-reason-string FRAME_UNWIND_INNER_ID))" \
"previous frame inner to this frame \\(corrupt stack\\?\\)" \
"test unwind-stop-reason-string"
gdb_test "guile (print (format #f \"= ~A\" (frame-pc f0)))" \
"= \[0-9\]+" "test frame-pc"
gdb_test "guile (print (format #f \"= ~A\" (eq? (frame-older f0) f1)))" \
"= #t" "test frame-older"
gdb_test "guile (print (format #f \"= ~A\" (eq? (frame-newer f1) f0)))" \
"= #t" "test frame-newer"
gdb_test "guile (print (frame-read-var f0 \"variable_which_surely_doesnt_exist\"))" \
"ERROR: .*: Out of range: variable not found: \"variable_which_surely_doesnt_exist\".*" \
"test frame-read-var - error"
gdb_test "guile (print (format #f \"= ~A\" (frame-read-var f0 \"a\")))" \
"= 1" "test frame-read-var - success"
gdb_test "guile (print (format #f \"= ~A\" (eq? (selected-frame) f1)))" \
"= #t" "test selected-frame"

View File

@ -0,0 +1,42 @@
# Copyright (C) 2010-2014 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 using GDB smobs with generics.
load_lib gdb-guile.exp
# Start with a fresh gdb.
gdb_exit
gdb_start
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
gdb_reinitialize_dir $srcdir/$subdir
gdb_install_guile_utils
gdb_install_guile_module
gdb_test_no_output "guile (use-modules ((oop goops)))"
gdb_test_no_output "guile (define-generic +)"
gdb_test_no_output "guile (define-method (+ (x <gdb:value>) (y <gdb:value>)) (value-add x y))"
gdb_test_no_output "guile (define x (make-value 42))"
gdb_test_no_output "guile (define y (+ x x))"
gdb_test "guile y" "#<gdb:value 84>"

View File

@ -0,0 +1,70 @@
# Copyright (C) 2014 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 basic gsmob features.
load_lib gdb-guile.exp
# Start with a fresh gdb.
gdb_exit
gdb_start
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
gdb_reinitialize_dir $srcdir/$subdir
gdb_install_guile_utils
gdb_install_guile_module
# Test the transition from alist to htab in the property list.
# N.B. This has the same value as gdb/guile/scm-gsmob.c.
set SMOB_PROP_HTAB_THRESHOLD 7
gdb_test_no_output "gu (define arch (current-arch))"
# Return a property name for integer I suitable for sorting.
proc prop_name { i } {
return [format "prop%02d" $i]
}
# Set and ref the properties in separate loops to verify previously set
# properties are not lost when we set a new property or switch to htabs.
for {set i 0} {$i <= $SMOB_PROP_HTAB_THRESHOLD} {incr i} {
gdb_test "gu (print (gsmob-has-property? arch '[prop_name $i]))" \
"= #f" "property prop$i not present before set"
gdb_test_no_output "gu (set-gsmob-property! arch '[prop_name $i] $i)" \
"set prop $i"
gdb_test "gu (print (gsmob-has-property? arch '[prop_name $i]))" \
"= #t" "property prop$i present after set"
}
for {set i 0} {$i <= $SMOB_PROP_HTAB_THRESHOLD} {incr i} {
gdb_test "gu (print (gsmob-has-property? arch '[prop_name $i]))" \
"= #t" "property prop$i present after all set"
gdb_test "gu (print (gsmob-property arch '[prop_name $i]))" \
"= $i" "ref prop $i"
}
# Verify gsmob-properties.
set prop_list ""
for {set i 0} {$i <= $SMOB_PROP_HTAB_THRESHOLD} {incr i} {
set prop_list "$prop_list [prop_name $i]"
}
set prop_list [lsort $prop_list]
verbose -log "prop_list: $prop_list"
gdb_test "gu (print (sort (gsmob-properties arch) (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))" \
"= \\($prop_list\\)" "gsmob-properties"

View File

@ -0,0 +1,28 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2014 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/>. */
void
foo (void)
{
}
int
main (void)
{
foo ();
return 0; /* Break at end. */
}

View File

@ -0,0 +1,62 @@
# Copyright (C) 2014 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 iterator facility.
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 "Break at end."]
gdb_continue_to_breakpoint "Break at end."
gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
"import (gdb iterator)"
gdb_scm_test_silent_cmd "guile (define this-sal (find-pc-line (frame-pc (selected-frame))))" \
"get frame sal"
gdb_scm_test_silent_cmd "guile (define this-symtab (sal-symtab this-sal))" \
"get frame symtab"
gdb_scm_test_silent_cmd "guile (define this-global-block (symtab-global-block this-symtab))" \
"get frame global block"
gdb_scm_test_silent_cmd "guile (define syms-iter (make-block-symbols-iterator this-global-block))" \
"get global block iterator"
gdb_scm_test_silent_cmd "guile (define functions (iterator-filter symbol-function? syms-iter))" \
"get global functions"
gdb_test "guile (print (sort (map symbol-name functions) string<?))" \
"= \\(foo main\\)" "test function list"
gdb_scm_test_silent_cmd "guile (define syms-iter (make-block-symbols-iterator this-global-block))" \
"get global block iterator 2"
gdb_test "guile (print (sort (map symbol-name (iterator->list syms-iter)) string<?))" \
"= \\(foo main\\)" "iterator->list"

View File

@ -0,0 +1,30 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2014 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/>. */
enum e
{
ONE = 1,
TWO = 2
};
enum e evalue = TWO;
int
main (int argc, char *argv[])
{
return 0;
}

View File

@ -0,0 +1,309 @@
# Copyright (C) 2008-2014 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 <gdb:value> math operations.
load_lib gdb-guile.exp
standard_testfile
proc test_value_numeric_ops {} {
global gdb_prompt
gdb_scm_test_silent_cmd "gu (define i (make-value 5))" \
"create first integer value"
gdb_scm_test_silent_cmd "gu (define j (make-value 2))" \
"create second integer value"
gdb_test "gu (print (value-add i j))" \
"= 7" "add two integer values"
gdb_test "gu (raw-print (value-add i j))" \
"= #<gdb:value 7>" "verify type of integer add result"
gdb_scm_test_silent_cmd "gu (define f (make-value 1.25))" \
"create first double value"
gdb_scm_test_silent_cmd "gu (define g (make-value 2.5))" \
"create second double value"
gdb_test "gu (print (value-add f g))" \
"= 3.75" "add two double values"
gdb_test "gu (raw-print (value-add f g))" \
"= #<gdb:value 3.75>" "verify type of double add result"
gdb_test "gu (print (value-sub i j))" \
"= 3" "subtract two integer values"
gdb_test "gu (print (value-sub f g))" \
"= -1.25" "subtract two double values"
gdb_test "gu (print (value-mul i j))" \
"= 10" "multiply two integer values"
gdb_test "gu (print (value-mul f g))" \
"= 3.125" "multiply two double values"
gdb_test "gu (print (value-div i j))" \
"= 2" "divide two integer values"
gdb_test "gu (print (value-div f g))" \
"= 0.5" "divide two double values"
gdb_test "gu (print (value-rem i j))" \
"= 1" "take remainder of two integer values"
gdb_test "gu (print (value-mod i j))" \
"= 1" "take modulus of two integer values"
gdb_test "gu (print (value-pow i j))" \
"= 25" "integer value raised to the power of another integer value"
gdb_test "gu (print (value-pow g j))" \
"= 6.25" "double value raised to the power of integer value"
gdb_test "gu (print (value-neg i))" \
"= -5" "negated integer value"
gdb_test "gu (print (value-pos i))" \
"= 5" "positive integer value"
gdb_test "gu (print (value-neg f))" \
"= -1.25" "negated double value"
gdb_test "gu (print (value-pos f))" \
"= 1.25" "positive double value"
gdb_test "gu (print (value-abs (value-sub j i)))" \
"= 3" "absolute of integer value"
gdb_test "gu (print (value-abs (value-sub f g)))" \
"= 1.25" "absolute of double value"
gdb_test "gu (print (value-lsh i j))" \
"= 20" "left shift"
gdb_test "gu (print (value-rsh i j))" \
"= 1" "right shift"
gdb_test "gu (print (value-min i j))" \
"= 2" "min"
gdb_test "gu (print (value-max i j))" \
"= 5" "max"
gdb_test "gu (print (value-lognot i))" \
"= -6" "lognot"
gdb_test "gu (print (value-logand i j))" \
"= 0" "logand i j"
gdb_test "gu (print (value-logand 5 1))" \
"= 1" "logand 5 1"
gdb_test "gu (print (value-logior i j))" \
"= 7" "logior i j"
gdb_test "gu (print (value-logior 5 1))" \
"= 5" "logior 5 1"
gdb_test "gu (print (value-logxor i j))" \
"= 7" "logxor i j"
gdb_test "gu (print (value-logxor 5 1))" \
"= 4" "logxor 5 1"
# Test <gdb:value> mixed with Guile types.
gdb_test "gu (print (value-sub i 1))" \
"= 4" "subtract integer value from guile integer"
gdb_test "gu (raw-print (value-sub i 1))" \
"#<gdb:value 4>" \
"verify type of mixed integer subtraction result"
gdb_test "gu (print (value-add f 1.5))" \
"= 2.75" "add double value with guile float"
gdb_test "gu (print (value-sub 1 i))" \
"= -4" "subtract guile integer from integer value"
gdb_test "gu (print (value-add 1.5 f))" \
"= 2.75" "add guile float with double value"
# Enum conversion test.
gdb_test "print evalue" "= TWO"
gdb_test "gu (print (value->integer (history-ref 0)))" "= 2"
# Test pointer arithmetic.
# First, obtain the pointers.
gdb_test "print (void *) 2" ".*" ""
gdb_test_no_output "gu (define a (history-ref 0))"
gdb_test "print (void *) 5" ".*" ""
gdb_test_no_output "gu (define b (history-ref 0))"
gdb_test "gu (print (value-add a 5))" \
"= 0x7( <.*>)?" "add pointer value with guile integer"
gdb_test "gu (print (value-sub b 2))" \
"= 0x3( <.*>)?" "subtract guile integer from pointer value"
gdb_test "gu (print (value-sub b a))" \
"= 3" "subtract two pointer values"
# Test some invalid operations.
gdb_test_multiple "gu (print (value-add i '()))" "catch error in guile type conversion" {
-re "Wrong type argument in position 2.*$gdb_prompt $" {pass "catch error in guile type conversion"}
-re "= .*$gdb_prompt $" {fail "catch error in guile type conversion"}
-re "$gdb_prompt $" {fail "catch error in guile type conversion"}
}
gdb_test_multiple "gu (print (value-add i \"foo\"))" "catch throw of GDB error" {
-re "Argument to arithmetic operation not a number or boolean.*$gdb_prompt $" {pass "catch throw of GDB error"}
-re "= .*$gdb_prompt $" {fail "catch throw of GDB error"}
-re "$gdb_prompt $" {fail "catch throw of GDB error"}
}
}
# Return the max signed int of size SIZE.
# TCL 8.5 required here. Use lookup table instead?
proc get_max_int { size } {
return [expr "(1 << ($size - 1)) - 1"]
}
# Return the min signed int of size SIZE.
# TCL 8.5 required here. Use lookup table instead?
proc get_min_int { size } {
return [expr "-(1 << ($size - 1))"]
}
# Return the max unsigned int of size SIZE.
# TCL 8.5 required here. Use lookup table instead?
proc get_max_uint { size } {
return [expr "(1 << $size) - 1"]
}
# Helper routine for test_value_numeric_ranges.
proc test_make_int_value { name size } {
set max [get_max_int $size]
set min [get_min_int $size]
set umax [get_max_uint $size]
gdb_test "gu (print (value-type (make-value $max)))" \
"= $name" "test make-value $name $size max"
gdb_test "gu (print (value-type (make-value $min)))" \
"= $name" "test make-value $name $size min"
gdb_test "gu (print (value-type (make-value $umax)))" \
"= unsigned $name" "test make-value unsigned $name $size umax"
}
# Helper routine for test_value_numeric_ranges.
proc test_make_typed_int_value { size } {
set name "int$size"
set uname "uint$size"
set max [get_max_int $size]
set min [get_min_int $size]
set umax [get_max_uint $size]
gdb_test "gu (print (make-value $max #:type (arch-${name}-type arch)))" \
"= $max" "test make-value $name $size max"
gdb_test "gu (print (make-value $min #:type (arch-${name}-type arch)))" \
"= $min" "test make-value $name $size min"
gdb_test "gu (print (make-value $umax #:type (arch-${uname}-type arch)))" \
"= $umax" "test make-value $uname $size umax"
gdb_test "gu (print (make-value (+ $max 1) #:type (arch-${name}-type arch)))" \
"ERROR.*Out of range.*" "test make-value $name $size max+1"
gdb_test "gu (print (make-value (- $min 1) #:type (arch-${name}-type arch)))" \
"ERROR.*Out of range.*" "test make-value $name $size min-1"
gdb_test "gu (print (make-value (+ $umax 1) #:type (arch-${uname}-type arch)))" \
"ERROR.*Out of range.*" "test make-value $uname $size umax+1"
}
proc test_value_numeric_ranges {} {
# We can't assume anything about sizeof (int), etc. on the target.
# Keep it simple for now, this will cover everything important for
# the major targets.
set int_size [get_sizeof "int" 0]
set long_size [get_sizeof "long" 0]
gdb_test_no_output "gu (define arch (current-arch))"
if { $int_size == 4 } {
test_make_int_value int 32
}
if { $long_size == 8} {
test_make_int_value long 64
}
gdb_test "gu (print (value-type (make-value (ash 1 64))))" \
"ERROR:.*value not a number representable.*" \
"test make-value, number too large"
foreach size { 8 16 32 } {
test_make_typed_int_value $size
}
if { $long_size == 8 } {
test_make_typed_int_value 64
}
}
proc test_value_boolean {} {
# Note: Boolean values print as 0,1 because they are printed in the
# current language (in this case C).
gdb_test "gu (print (make-value #t))" "= 1" "create boolean true"
gdb_test "gu (print (make-value #f))" "= 0" "create boolean false"
gdb_test "gu (print (value-not (make-value #t)))" \
"= 0" "not true"
gdb_test "gu (print (value-not (make-value #f)))" \
"= 1" "not false"
gdb_test "gu (raw-print (make-value #t))" \
"#<gdb:value 1>" "verify type of boolean"
}
proc test_value_compare {} {
gdb_test "gu (print (value<? 1 1))" \
"#f" "less than, equal"
gdb_test "gu (print (value<? 1 2))" \
"#t" "less than, less"
gdb_test "gu (print (value<? 2 1))" \
"#f" "less than, greater"
gdb_test "gu (print (value<=? 1 1))" \
"#t" "less or equal, equal"
gdb_test "gu (print (value<=? 1 2))" \
"#t" "less or equal, less"
gdb_test "gu (print (value<=? 2 1))" \
"#f" "less or equal, greater"
gdb_test "gu (print (value=? 1 1))" \
"#t" "equality"
gdb_test "gu (print (value=? 1 2))" \
"#f" "inequality"
gdb_test "gu (print (value=? (make-value 1) 1.0))" \
"#t" "equality of gdb:value with Guile value"
gdb_test "gu (print (value=? (make-value 1) 2))" \
"#f" "inequality of gdb:value with Guile value"
gdb_test "gu (print (value>? 1 1))" \
"#f" "greater than, equal"
gdb_test "gu (print (value>? 1 2))" \
"#f" "greater than, less"
gdb_test "gu (print (value>? 2 1))" \
"#t" "greater than, greater"
gdb_test "gu (print (value>=? 1 1))" \
"#t" "greater or equal, equal"
gdb_test "gu (print (value>=? 1 2))" \
"#f" "greater or equal, less"
gdb_test "gu (print (value>=? 2 1))" \
"#t" "greater or equal, greater"
}
if {[prepare_for_testing $testfile.exp $testfile $srcfile {debug c}]} {
return
}
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
if ![gdb_guile_runto_main] {
return
}
test_value_numeric_ops
test_value_numeric_ranges
test_value_boolean
test_value_compare

View File

@ -0,0 +1,55 @@
;; Copyright (C) 2011-2014 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.
(use-modules (gdb) (gdb printing))
(define (make-pp_ss-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(let ((a (value-field val "a"))
(b (value-field val "b")))
(format #f "a=<~A> b=<~A>" a b)))
#f))
(define (get-type-for-printing val)
"Return type of val, stripping away typedefs, etc."
(let ((type (value-type val)))
(if (= (type-code type) TYPE_CODE_REF)
(set! type (type-target type)))
(type-strip-typedefs (type-unqualified type))))
(define (make-pretty-printer-dict)
(let ((dict (make-hash-table)))
(hash-set! dict "struct ss" make-pp_ss-printer)
(hash-set! dict "ss" make-pp_ss-printer)
dict))
(define *pretty-printer*
(make-pretty-printer
"pretty-printer-test"
(let ((pretty-printers-dict (make-pretty-printer-dict)))
(lambda (matcher val)
"Look-up and return a pretty-printer that can print val."
(let ((type (get-type-for-printing val)))
(let ((typename (type-tag type)))
(if typename
(let ((printer-maker (hash-ref pretty-printers-dict typename)))
(and printer-maker (printer-maker val)))
#f)))))))
(append-pretty-printer! #f *pretty-printer*)

View File

@ -0,0 +1,39 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2011-2014 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/>. */
struct ss
{
int a;
int b;
};
void
init_ss (struct ss *s, int a, int b)
{
s->a = a;
s->b = b;
}
int
main ()
{
struct ss ss;
init_ss (&ss, 1, 2);
return 0; /* break to inspect struct and union */
}

View File

@ -0,0 +1,57 @@
# Copyright (C) 2011-2014 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 automagic loading of -gdb.scm scripts.
load_lib gdb-guile.exp
standard_testfile
if {[build_executable $testfile.exp $testfile $srcfile debug] == -1} {
return
}
# Start with a fresh gdb.
gdb_exit
gdb_start
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
# Make the -gdb.scm script available to gdb, it is automagically loaded by gdb.
# Care is taken to put it in the same directory as the binary so that
# gdb will find it.
set remote_guile_file [remote_download host \
${srcdir}/${subdir}/${testfile}-gdb.in \
[standard_output_file ${testfile}-gdb.scm]]
gdb_reinitialize_dir $srcdir/$subdir
gdb_test_no_output "set auto-load safe-path ${remote_guile_file}" \
"set auto-load safe-path"
gdb_load ${binfile}
# Verify gdb loaded the script.
gdb_test "info auto-load guile-scripts" "Yes.*/${testfile}-gdb.scm.*"
if ![gdb_guile_runto_main] {
return
}
gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
".*Breakpoint.*"
gdb_test "continue" ".*Breakpoint.*"
gdb_test "print ss" " = a=<1> b=<2>"

View File

@ -0,0 +1,23 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2011-2014 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
main ()
{
int some_var = 0;
return 0;
}

View File

@ -0,0 +1,57 @@
# Copyright (C) 2011-2014 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 objfile support in Guile.
load_lib gdb-guile.exp
standard_testfile
if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
return
}
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
if ![gdb_guile_runto_main] {
fail "Can't run to main"
return
}
gdb_scm_test_silent_cmd "gu (define sym (lookup-symbol \"some_var\"))" \
"Find a symbol in objfile"
gdb_scm_test_silent_cmd "gu (define objfile (symtab-objfile (symbol-symtab (car sym))))" \
"Get backing object file"
gdb_test "gu (print (objfile-filename objfile))" \
".*scm-objfile.*" "Get objfile filename"
gdb_test "gu (print (objfile-valid? objfile))" \
"#t" "Get objfile validity"
gdb_test "gu (print (->bool (or-map (lambda (o) (string-contains (objfile-filename o) \"scm-objfile\")) (objfiles))))" \
"= #t" "scm-objfile in objfile list"
gdb_test "gu (print (objfile-pretty-printers objfile))" \
"= \\(\\)"
gdb_test "guile (set-objfile-pretty-printers! objfile 0)" \
"ERROR: .*: Wrong type argument in position 2 \\(expecting list\\): 0.*"
# Do this last.
gdb_unload
gdb_test "gu (print (objfile-valid? objfile))" \
"#f" "Get objfile validity after unload"

View File

@ -0,0 +1,37 @@
# Copyright (C) 2014 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 GDB provided ports.
load_lib gdb-guile.exp
# Start with a fresh gdb.
gdb_exit
gdb_start
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
gdb_reinitialize_dir $srcdir/$subdir
gdb_install_guile_utils
gdb_install_guile_module
gdb_test "guile (print (stdio-port? 42))" "= #f"
gdb_test "guile (print (stdio-port? (%make-void-port \"r\")))" "= #f"
gdb_test "guile (print (stdio-port? (input-port)))" "= #t"
gdb_test "guile (print (stdio-port? (output-port)))" "= #t"
gdb_test "guile (print (stdio-port? (error-port)))" "= #t"

View File

@ -0,0 +1,353 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2008-2014 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/>. */
#include <string.h>
struct s
{
int a;
int *b;
};
struct ss
{
struct s a;
struct s b;
};
struct arraystruct
{
int y;
struct s x[2];
};
struct ns {
const char *null_str;
int length;
};
struct lazystring {
const char *lazy_str;
};
struct hint_error {
int x;
};
struct children_as_list {
int x;
};
#ifdef __cplusplus
struct S : public s {
int zs;
};
struct SS {
int zss;
S s;
};
struct SSS
{
SSS (int x, const S& r);
int a;
const S &b;
};
SSS::SSS (int x, const S& r) : a(x), b(r) { }
class VirtualTest
{
private:
int value;
public:
VirtualTest ()
{
value = 1;
}
};
class Vbase1 : public virtual VirtualTest { };
class Vbase2 : public virtual VirtualTest { };
class Vbase3 : public virtual VirtualTest { };
class Derived : public Vbase1, public Vbase2, public Vbase3
{
private:
int value;
public:
Derived ()
{
value = 2;
}
};
class Fake
{
int sname;
public:
Fake (const int name = 0):
sname (name)
{
}
};
#endif
struct substruct {
int a;
int b;
};
struct outerstruct {
struct substruct s;
int x;
};
struct outerstruct
substruct_test (void)
{
struct outerstruct outer;
outer.s.a = 0;
outer.s.b = 0;
outer.x = 0;
outer.s.a = 3; /* MI outer breakpoint here */
return outer;
}
typedef struct string_repr
{
struct whybother
{
const char *contents;
} whybother;
} string;
/* This lets us avoid malloc. */
int array[100];
int narray[10];
struct justchildren
{
int len;
int *elements;
};
typedef struct justchildren nostring_type;
struct memory_error
{
const char *s;
};
struct container
{
string name;
int len;
int *elements;
};
typedef struct container zzz_type;
string
make_string (const char *s)
{
string result;
result.whybother.contents = s;
return result;
}
zzz_type
make_container (const char *s)
{
zzz_type result;
result.name = make_string (s);
result.len = 0;
result.elements = 0;
return result;
}
void
add_item (zzz_type *c, int val)
{
if (c->len == 0)
c->elements = array;
c->elements[c->len] = val;
++c->len;
}
void
set_item(zzz_type *c, int i, int val)
{
if (i < c->len)
c->elements[i] = val;
}
void init_s(struct s *s, int a)
{
s->a = a;
s->b = &s->a;
}
void init_ss(struct ss *s, int a, int b)
{
init_s(&s->a, a);
init_s(&s->b, b);
}
void do_nothing(void)
{
int c;
c = 23; /* Another MI breakpoint */
}
struct nullstr
{
char *s;
};
struct string_repr string_1 = { { "one" } };
struct string_repr string_2 = { { "two" } };
static int
eval_func (int p1, int p2, int p3, int p4, int p5, int p6, int p7, int p8)
{
return p1;
}
static void
eval_sub (void)
{
struct eval_type_s { int x; } eval1 = { 1 }, eval2 = { 2 }, eval3 = { 3 },
eval4 = { 4 }, eval5 = { 5 }, eval6 = { 6 },
eval7 = { 7 }, eval8 = { 8 }, eval9 = { 9 };
eval1.x++; /* eval-break */
}
static void
bug_14741()
{
zzz_type c = make_container ("bug_14741");
add_item (&c, 71);
set_item(&c, 0, 42); /* breakpoint bug 14741 */
set_item(&c, 0, 5);
}
int
main ()
{
struct ss ss;
struct ss ssa[2];
struct arraystruct arraystruct;
string x = make_string ("this is x");
zzz_type c = make_container ("container");
zzz_type c2 = make_container ("container2");
const struct string_repr cstring = { { "const string" } };
/* Clearing by being `static' could invoke an other GDB C++ bug. */
struct nullstr nullstr;
nostring_type nstype, nstype2;
struct memory_error me;
struct ns ns, ns2;
struct lazystring estring, estring2;
struct hint_error hint_error;
struct children_as_list children_as_list;
nstype.elements = narray;
nstype.len = 0;
me.s = "blah";
init_ss(&ss, 1, 2);
init_ss(ssa+0, 3, 4);
init_ss(ssa+1, 5, 6);
memset (&nullstr, 0, sizeof nullstr);
arraystruct.y = 7;
init_s (&arraystruct.x[0], 23);
init_s (&arraystruct.x[1], 24);
ns.null_str = "embedded\0null\0string";
ns.length = 20;
/* Make a "corrupted" string. */
ns2.null_str = NULL;
ns2.length = 20;
estring.lazy_str = "embedded x\201\202\203\204" ;
/* Incomplete UTF-8, but ok Latin-1. */
estring2.lazy_str = "embedded x\302";
#ifdef __cplusplus
S cps;
cps.zs = 7;
init_s(&cps, 8);
SS cpss;
cpss.zss = 9;
init_s(&cpss.s, 10);
SS cpssa[2];
cpssa[0].zss = 11;
init_s(&cpssa[0].s, 12);
cpssa[1].zss = 13;
init_s(&cpssa[1].s, 14);
SSS sss(15, cps);
SSS& ref (sss);
Derived derived;
Fake fake (42);
#endif
add_item (&c, 23); /* MI breakpoint here */
add_item (&c, 72);
#ifdef MI
add_item (&c, 1011);
c.elements[0] = 1023;
c.elements[0] = 2323;
add_item (&c2, 2222);
add_item (&c2, 3333);
substruct_test ();
do_nothing ();
#endif
nstype.elements[0] = 7;
nstype.elements[1] = 42;
nstype.len = 2;
nstype2 = nstype;
eval_sub ();
bug_14741(); /* break to inspect struct and union */
return 0;
}

View File

@ -0,0 +1,148 @@
# Copyright (C) 2008-2014 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 Guile-based pretty-printing for the CLI.
load_lib gdb-guile.exp
standard_testfile
# Start with a fresh gdb.
gdb_exit
gdb_start
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
proc run_lang_tests {exefile lang} {
global srcdir subdir srcfile testfile hex
if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
untested "Couldn't compile ${srcfile} in $lang mode"
return
}
set nl "\[\r\n\]+"
# Start with a fresh gdb.
gdb_exit
gdb_start
gdb_reinitialize_dir $srcdir/$subdir
gdb_load ${exefile}
if ![gdb_guile_runto_main] {
return
}
gdb_test_no_output "set print pretty on"
gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
".*Breakpoint.*"
gdb_test "continue" ".*Breakpoint.*"
set remote_scheme_file [gdb_remote_download host \
${srcdir}/${subdir}/${testfile}.scm]
gdb_scm_load_file ${remote_scheme_file}
gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>"
gdb_test "print ssa\[1\]" " = a=<a=<5> b=<$hex>> b=<a=<6> b=<$hex>>"
gdb_test "print ssa" " = {a=<a=<3> b=<$hex>> b=<a=<4> b=<$hex>>, a=<a=<5> b=<$hex>> b=<a=<6> b=<$hex>>}"
gdb_test "print arraystruct" " = {$nl *y = 7, *$nl *x = {a=<23> b=<$hex>, a=<24> b=<$hex>} *$nl *}"
if {$lang == "c++"} {
gdb_test "print cps" "= a=<8> b=<$hex>"
gdb_test "print cpss" " = {$nl *zss = 9, *$nl *s = a=<10> b=<$hex>$nl}"
gdb_test "print cpssa\[0\]" " = {$nl *zss = 11, *$nl *s = a=<12> b=<$hex>$nl}"
gdb_test "print cpssa\[1\]" " = {$nl *zss = 13, *$nl *s = a=<14> b=<$hex>$nl}"
gdb_test "print cpssa" " = {{$nl *zss = 11, *$nl *s = a=<12> b=<$hex>$nl *}, {$nl *zss = 13, *$nl *s = a=<14> b=<$hex>$nl *}}"
gdb_test "print sss" "= a=<15> b=<a=<8> b=<$hex>>"
gdb_test "print ref" "= a=<15> b=<a=<8> b=<$hex>>"
gdb_test "print derived" \
" = \{.*<Vbase1> = pp class name: Vbase1.*<Vbase2> = \{.*<VirtualTest> = pp value variable is: 1,.*members of Vbase2:.*_vptr.Vbase2 = $hex.*<Vbase3> = \{.*members of Vbase3.*members of Derived:.*value = 2.*"
gdb_test "print ns " "\"embedded\\\\000null\\\\000string\""
gdb_scm_test_silent_cmd "set print elements 3" "" 1
gdb_test "print ns" "emb\.\.\.."
gdb_scm_test_silent_cmd "set print elements 10" "" 1
gdb_test "print ns" "embedded\\\\000n\.\.\.."
gdb_scm_test_silent_cmd "set print elements 200" "" 1
}
gdb_test "print ns2" "<error reading variable: ERROR: Cannot access memory at address 0x0>"
gdb_test "print x" " = \"this is x\""
gdb_test "print cstring" " = \"const string\""
gdb_test "print estring" " = \"embedded x\\\\201\\\\202\\\\203\\\\204\""
gdb_test_no_output "guile (set! *pp-ls-encoding* \"UTF-8\")"
gdb_test "print estring2" "\"embedded \", <incomplete sequence \\\\302>"
gdb_test_no_output "set guile print-stack full"
gdb_test "print hint_error" "ERROR: Invalid display hint: 42\r\nhint_error_val"
gdb_test "print c" " = container \"container\" with 2 elements = {$nl *.0. = 23,$nl *.1. = 72$nl}"
gdb_test "print nstype" " = {$nl *.0. = 7,$nl *.1. = 42$nl}"
gdb_test_no_output "set print pretty off"
gdb_test "print nstype" " = {.0. = 7, .1. = 42}" \
"print nstype on one line"
gdb_continue_to_end
}
run_lang_tests "${binfile}" "c"
run_lang_tests "${binfile}-cxx" "c++"
# Run various other tests.
# Start with a fresh gdb.
gdb_exit
gdb_start
gdb_reinitialize_dir $srcdir/$subdir
gdb_load ${binfile}
if ![gdb_guile_runto_main] {
return
}
set remote_scheme_file [gdb_remote_download host \
${srcdir}/${subdir}/${testfile}.scm]
gdb_scm_load_file ${remote_scheme_file}
gdb_breakpoint [gdb_get_line_number "eval-break"]
gdb_continue_to_breakpoint "eval-break" ".* eval-break .*"
gdb_test "info locals" "eval9 = eval=<123456789>"
gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
".*Breakpoint.*"
gdb_test "continue" ".*Breakpoint.*"
gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
"print ss enabled #1"
gdb_test_no_output "guile (disable-matcher!)"
gdb_test "print ss" " = {a = {a = 1, b = $hex}, b = {a = 2, b = $hex}}" \
"print ss disabled"
gdb_test_no_output "guile (enable-matcher!)"
gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
"print ss enabled #2"

View File

@ -0,0 +1,301 @@
;; Copyright (C) 2008-2014 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 Scheme pretty printers.
(use-modules (gdb) (gdb printing))
(define (make-pointer-iterator pointer len)
(let ((next! (lambda (iter)
(let* ((start (iterator-object iter))
(progress (iterator-progress iter))
(current (car progress))
(len (cdr progress)))
(if (= current len)
(end-of-iteration)
(let ((pointer (value-add start current)))
(set-car! progress (+ current 1))
(cons (format #f "[~A]" current)
(value-dereference pointer))))))))
(make-iterator pointer (cons 0 len) next!)))
(define (make-pointer-iterator-except pointer len)
(let ((next! (lambda (iter)
(if *exception-flag*
(throw 'gdb:memory-error "hi bob"))
(let* ((start (iterator-object iter))
(progress (iterator-progress iter))
(current (car progress))
(len (cdr progress)))
(if (= current len)
(end-of-iteration)
(let ((pointer (value-add start current)))
(set-car! progress (+ current 1))
(cons (format #f "[~A]" current)
(value-dereference pointer))))))))
(make-iterator pointer (cons 0 len) next!)))
;; Test returning a <gdb:value> from a printer.
(define (make-string-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(value-field (value-field val "whybother")
"contents"))
#f))
;; Test a printer with children.
(define (make-container-printer val)
;; This is a little different than the Python version in that if there's
;; an error accessing these fields we'll throw it at matcher time instead
;; of at printer time. Done this way to explore the possibilities.
(let ((name (value-field val "name"))
(len (value-field val "len"))
(elements (value-field val "elements")))
(make-pretty-printer-worker
#f
(lambda (printer)
(format #f "container ~A with ~A elements"
name len))
(lambda (printer)
(make-pointer-iterator elements (value->integer len))))))
;; Test "array" display hint.
(define (make-array-printer val)
(let ((name (value-field val "name"))
(len (value-field val "len"))
(elements (value-field val "elements")))
(make-pretty-printer-worker
"array"
(lambda (printer)
(format #f "array ~A with ~A elements"
name len))
(lambda (printer)
(make-pointer-iterator elements (value->integer len))))))
;; Flag to make no-string-container printer throw an exception.
(define *exception-flag* #f)
;; Test a printer where to_string returns #f.
(define (make-no-string-container-printer val)
(let ((len (value-field val "len"))
(elements (value-field val "elements")))
(make-pretty-printer-worker
#f
(lambda (printer) #f)
(lambda (printer)
(make-pointer-iterator-except elements (value->integer len))))))
(define (make-pp_s-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(let ((a (value-field val "a"))
(b (value-field val "b")))
(if (not (value=? (value-address a) b))
(error (format #f "&a(~A) != b(~A)"
(value-address a) b)))
(format #f "a=<~A> b=<~A>" a b)))
#f))
(define (make-pp_ss-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(let ((a (value-field val "a"))
(b (value-field val "b")))
(format #f "a=<~A> b=<~A>" a b)))
#f))
(define (make-pp_sss-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(let ((a (value-field val "a"))
(b (value-field val "b")))
(format #f "a=<~A> b=<~A>" a b)))
#f))
(define (make-pp_multiple_virtual-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(format #f "pp value variable is: ~A" (value-field val "value")))
#f))
(define (make-pp_vbase1-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(format #f "pp class name: ~A" (type-tag (value-type val))))
#f))
(define (make-pp_nullstr-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(value->string (value-field val "s")
#:encoding (arch-charset (current-arch))))
#f))
(define (make-pp_ns-printer val)
(make-pretty-printer-worker
"string"
(lambda (printer)
(let ((len (value-field val "length")))
(value->string (value-field val "null_str")
#:encoding (arch-charset (current-arch))
#:length (value->integer len))))
#f))
(define *pp-ls-encoding* #f)
(define (make-pp_ls-printer val)
(make-pretty-printer-worker
"string"
(lambda (printer)
(if *pp-ls-encoding*
(value->lazy-string (value-field val "lazy_str")
#:encoding *pp-ls-encoding*)
(value->lazy-string (value-field val "lazy_str"))))
#f))
(define (make-pp_hint_error-printer val)
"Use an invalid value for the display hint."
(make-pretty-printer-worker
42
(lambda (printer) "hint_error_val")
#f))
(define (make-pp_children_as_list-printer val)
(make-pretty-printer-worker
#f
(lambda (printer) "children_as_list_val")
(lambda (printer) (make-list-iterator (list (cons "one" 1))))))
(define (make-pp_outer-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(format #f "x = ~A" (value-field val "x")))
(lambda (printer)
(make-list-iterator (list (cons "s" (value-field val "s"))
(cons "x" (value-field val "x")))))))
(define (make-memory-error-string-printer val)
(make-pretty-printer-worker
"string"
(lambda (printer)
(scm-error 'gdb:memory-error "memory-error-printer"
"Cannot access memory." '() '()))
#f))
(define (make-pp_eval_type-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(execute "bt" #:to-string #t)
(format #f "eval=<~A>"
(value-print
(parse-and-eval
"eval_func (123456789, 2, 3, 4, 5, 6, 7, 8)"))))
#f))
(define (get-type-for-printing val)
"Return type of val, stripping away typedefs, etc."
(let ((type (value-type val)))
(if (= (type-code type) TYPE_CODE_REF)
(set! type (type-target type)))
(type-strip-typedefs (type-unqualified type))))
(define (disable-matcher!)
(set-pretty-printer-enabled! *pretty-printer* #f))
(define (enable-matcher!)
(set-pretty-printer-enabled! *pretty-printer* #t))
(define (make-pretty-printer-dict)
(let ((dict (make-hash-table)))
(hash-set! dict "struct s" make-pp_s-printer)
(hash-set! dict "s" make-pp_s-printer)
(hash-set! dict "S" make-pp_s-printer)
(hash-set! dict "struct ss" make-pp_ss-printer)
(hash-set! dict "ss" make-pp_ss-printer)
(hash-set! dict "const S &" make-pp_s-printer)
(hash-set! dict "SSS" make-pp_sss-printer)
(hash-set! dict "VirtualTest" make-pp_multiple_virtual-printer)
(hash-set! dict "Vbase1" make-pp_vbase1-printer)
(hash-set! dict "struct nullstr" make-pp_nullstr-printer)
(hash-set! dict "nullstr" make-pp_nullstr-printer)
;; Note that we purposely omit the typedef names here.
;; Printer lookup is based on canonical name.
;; However, we do need both tagged and untagged variants, to handle
;; both the C and C++ cases.
(hash-set! dict "struct string_repr" make-string-printer)
(hash-set! dict "struct container" make-container-printer)
(hash-set! dict "struct justchildren" make-no-string-container-printer)
(hash-set! dict "string_repr" make-string-printer)
(hash-set! dict "container" make-container-printer)
(hash-set! dict "justchildren" make-no-string-container-printer)
(hash-set! dict "struct ns" make-pp_ns-printer)
(hash-set! dict "ns" make-pp_ns-printer)
(hash-set! dict "struct lazystring" make-pp_ls-printer)
(hash-set! dict "lazystring" make-pp_ls-printer)
(hash-set! dict "struct outerstruct" make-pp_outer-printer)
(hash-set! dict "outerstruct" make-pp_outer-printer)
(hash-set! dict "struct hint_error" make-pp_hint_error-printer)
(hash-set! dict "hint_error" make-pp_hint_error-printer)
(hash-set! dict "struct children_as_list"
make-pp_children_as_list-printer)
(hash-set! dict "children_as_list" make-pp_children_as_list-printer)
(hash-set! dict "memory_error" make-memory-error-string-printer)
(hash-set! dict "eval_type_s" make-pp_eval_type-printer)
dict))
;; This is one way to register a printer that is composed of several
;; subprinters, but there's no way to disable or list individual subprinters.
(define *pretty-printer*
(make-pretty-printer
"pretty-printer-test"
(let ((pretty-printers-dict (make-pretty-printer-dict)))
(lambda (matcher val)
"Look-up and return a pretty-printer that can print val."
(let ((type (get-type-for-printing val)))
(let ((typename (type-tag type)))
(if typename
(let ((printer-maker (hash-ref pretty-printers-dict typename)))
(and printer-maker (printer-maker val)))
#f)))))))
(append-pretty-printer! #f *pretty-printer*)

View File

@ -0,0 +1,55 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2010-2014 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/>. */
#include "symcat.h"
#include "gdb/section-scripts.h"
/* Put the path to the pretty-printer script in .debug_gdb_scripts so
gdb will automagically loaded it. */
#define DEFINE_GDB_SCRIPT(script_name) \
asm("\
.pushsection \".debug_gdb_scripts\", \"MS\",@progbits,1\n\
.byte " XSTRING (SECTION_SCRIPT_ID_SCHEME_FILE) "\n\
.asciz \"" script_name "\"\n\
.popsection \n\
");
DEFINE_GDB_SCRIPT (SCRIPT_FILE)
struct ss
{
int a;
int b;
};
void
init_ss (struct ss *s, int a, int b)
{
s->a = a;
s->b = b;
}
int
main ()
{
struct ss ss;
init_ss (&ss, 1, 2);
return 0; /* break to inspect struct and union */
}

View File

@ -0,0 +1,80 @@
# Copyright (C) 2010-2014 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 automagic loading of
# scripts specified in the .debug_gdb_scripts section.
# This test can only be run on targets which support ELF and use gas.
# For now pick a sampling of likely targets.
if {![istarget *-*-linux*]
&& ![istarget *-*-gnu*]
&& ![istarget *-*-elf*]
&& ![istarget *-*-openbsd*]
&& ![istarget arm*-*-eabi*]
&& ![istarget arm*-*-symbianelf*]
&& ![istarget powerpc-*-eabi*]} {
verbose "Skipping scm-section-script.exp because of lack of support."
return
}
load_lib gdb-guile.exp
standard_testfile
# Make this available to gdb before the program starts, it is
# automagically loaded by gdb.
# Give the file a new name so we don't clobber the real one if
# objfile == srcdir.
# We also need to do this before compiling the program because the name
# of the script file is encoded in the binary.
# FIXME: Can we get gdb_remote_download to call standard_output_file for us?
set remote_guile_file [gdb_remote_download host \
${srcdir}/${subdir}/${testfile}.scm \
${subdir}/t-${testfile}.scm]
if {[build_executable $testfile.exp $testfile $srcfile \
[list debug "additional_flags=-I${srcdir}/../../include -DSCRIPT_FILE=\"$remote_guile_file\""]] == -1} {
return
}
# Start with a fresh gdb.
gdb_exit
gdb_start
# Skip all tests if Guile scripting is not enabled.
if { [skip_guile_tests] } { continue }
gdb_reinitialize_dir $srcdir/$subdir
gdb_test_no_output "set auto-load safe-path ${remote_guile_file}" \
"set auto-load safe-path"
gdb_load ${binfile}
# Verify gdb loaded the script.
gdb_test "info auto-load guile-scripts" "Yes.*${testfile}.scm.*"
# Again, with a regexp this time.
gdb_test "info auto-load guile-scripts ${testfile}" "Yes.*${testfile}.scm.*"
# Again, with a regexp that matches no scripts.
gdb_test "info auto-load guile-scripts no-script-matches-this" \
"No auto-load scripts matching no-script-matches-this."
if ![gdb_guile_runto_main] {
return
}
gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
".*Breakpoint.*"
gdb_test "continue" ".*Breakpoint.*"
gdb_test "print ss" " = a=<1> b=<2>"

View File

@ -0,0 +1,55 @@
;; Copyright (C) 2010-2014 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.
(use-modules (gdb) (gdb printing))
(define (make-pp_ss-printer val)
(make-pretty-printer-worker
#f
(lambda (printer)
(let ((a (value-field val "a"))
(b (value-field val "b")))
(format #f "a=<~A> b=<~A>" a b)))
#f))
(define (get-type-for-printing val)
"Return type of val, stripping away typedefs, etc."
(let ((type (value-type val)))
(if (= (type-code type) TYPE_CODE_REF)
(set! type (type-target type)))
(type-strip-typedefs (type-unqualified type))))
(define (make-pretty-printer-dict)
(let ((dict (make-hash-table)))
(hash-set! dict "struct ss" make-pp_ss-printer)
(hash-set! dict "ss" make-pp_ss-printer)
dict))
(define *pretty-printer*
(make-pretty-printer
"pretty-printer-test"
(let ((pretty-printers-dict (make-pretty-printer-dict)))
(lambda (matcher val)
"Look-up and return a pretty-printer that can print val."
(let ((type (get-type-for-printing val)))
(let ((typename (type-tag type)))
(if typename
(let ((printer-maker (hash-ref pretty-printers-dict typename)))
(and printer-maker (printer-maker val)))
#f)))))))
(append-pretty-printer! #f *pretty-printer*)

View File

@ -0,0 +1,69 @@
/* This testcase is part of GDB, the GNU debugger.
Copyright 2010-2014 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. */
}

View File

@ -0,0 +1,196 @@
# Copyright (C) 2010-2014 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"

Some files were not shown because too many files have changed in this diff Show More