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:
parent
7026a7c16e
commit
ed3ef33944
|
@ -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).
|
||||
|
|
152
gdb/Makefile.in
152
gdb/Makefile.in
|
@ -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
|
||||
|
|
31
gdb/NEWS
31
gdb/NEWS
|
@ -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
|
||||
|
|
|
@ -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 ();
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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. */
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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. #
|
||||
# --------------------- #
|
||||
|
|
148
gdb/configure.ac
148
gdb/configure.ac
|
@ -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. #
|
||||
# --------------------- #
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -411,6 +411,7 @@ enum command_control_type
|
|||
if_control,
|
||||
commands_control,
|
||||
python_control,
|
||||
guile_control,
|
||||
while_stepping_control,
|
||||
invalid_control
|
||||
};
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -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
|
||||
};
|
||||
|
||||
|
|
|
@ -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. */
|
||||
|
|
|
@ -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,
|
||||
|
|
|
@ -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) \
|
||||
|
|
|
@ -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 ..."
|
|
@ -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 */
|
|
@ -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
|
||||
}
|
|
@ -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 */
|
|
@ -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
|
||||
)
|
|
@ -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))
|
|
@ -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))))
|
|
@ -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)
|
|
@ -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))))))
|
|
@ -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!))))
|
|
@ -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))
|
|
@ -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);
|
||||
}
|
|
@ -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 ());
|
||||
}
|
|
@ -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);
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -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");
|
||||
}
|
|
@ -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");
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -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);
|
||||
}
|
|
@ -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");
|
||||
}
|
|
@ -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);
|
||||
}
|
|
@ -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);
|
||||
}
|
|
@ -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);
|
||||
}
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -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);
|
||||
}
|
|
@ -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);
|
||||
}
|
|
@ -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);
|
||||
}
|
|
@ -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);
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -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));
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -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
|
||||
|
|
|
@ -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" ;;
|
||||
|
|
|
@ -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 \
|
||||
|
|
|
@ -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.*"
|
||||
|
|
|
@ -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
|
|
@ -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"
|
|
@ -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;
|
||||
}
|
|
@ -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"
|
|
@ -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. */
|
||||
}
|
|
@ -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"
|
|
@ -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. */
|
||||
}
|
|
@ -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
|
|
@ -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;
|
||||
}
|
|
@ -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"
|
|
@ -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;
|
||||
}
|
|
@ -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"
|
|
@ -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))
|
|
@ -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))
|
|
@ -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.*"
|
|
@ -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;
|
||||
}
|
|
@ -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"
|
|
@ -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*)
|
|
@ -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 ();
|
||||
}
|
|
@ -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"
|
|
@ -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);
|
||||
}
|
|
@ -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"
|
|
@ -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>"
|
|
@ -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"
|
|
@ -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. */
|
||||
}
|
|
@ -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"
|
|
@ -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;
|
||||
}
|
|
@ -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
|
|
@ -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*)
|
|
@ -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 */
|
||||
}
|
|
@ -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>"
|
|
@ -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;
|
||||
}
|
|
@ -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"
|
|
@ -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"
|
|
@ -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;
|
||||
}
|
|
@ -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"
|
|
@ -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*)
|
|
@ -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 */
|
||||
}
|
|
@ -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>"
|
|
@ -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*)
|
|
@ -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. */
|
||||
}
|
|
@ -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
Loading…
Reference in New Issue